--- /dev/null
+### -*-tcl-*-
+###
+### Common functions for certificate management.
+###
+### (c) 2011 Mark Wooding
+###
+
+###----- Licensing notice ---------------------------------------------------
+###
+### This program is free software; you can redistribute it and/or modify
+### it under the terms of the GNU General Public License as published by
+### the Free Software Foundation; either version 2 of the License, or
+### (at your option) any later version.
+###
+### This program is distributed in the hope that it will be useful,
+### but WITHOUT ANY WARRANTY; without even the implied warranty of
+### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+### GNU General Public License for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with this program; if not, write to the Free Software Foundation,
+### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+package require sqlite3
+
+###--------------------------------------------------------------------------
+### Command line conventions.
+
+set QUIS [file tail $argv0]
+set RC 0
+
+proc moan {message} {
+ ## Report MESSAGE as a warning message.
+
+ global QUIS
+ puts stderr "$QUIS: $message"
+}
+
+proc bad {level message} {
+ ## Report an error MESSAGE at badness LEVEL.
+
+ global RC
+ if {$level > $RC} { set RC $level }
+ moan $message
+}
+
+proc quit {} {
+ ## Exit the program.
+
+ global RC
+ exit $RC
+}
+
+proc die {message} {
+ ## Report an error MESSAGE and quit.
+
+ bad 1 $message
+ quit
+}
+
+###--------------------------------------------------------------------------
+### Find and read configuration.
+
+set CERTROOT [file normalize [file dirname [file dirname [info script]]]]
+
+## Default user configuration.
+set C(ca-owner) "root"
+set C(ca-user) "ca"
+set C(ca-group) "ca"
+
+## CA distinguished name.
+set C(ca-name) {
+ countryName "GB"
+ stateOrProvinceName "Borsetshire"
+ localityName "Ambridge"
+ organizationName "Archers' Omnibus Company"
+ organizationalUnitName "Certificate Authority"
+ commonName "Archers Omnibus Certificate Authority"
+ emailAddress "eddie.grundy@archers.example.com"
+}
+
+## Profiles.
+array unset P
+
+## Other random configuration.
+set C(ca-period) 3650
+set C(archive-interval) 32
+
+## Read the user configuration.
+if {[file exists "$CERTROOT/etc/config.tcl"]} {
+ source "$CERTROOT/etc/config.tcl"
+}
+
+###--------------------------------------------------------------------------
+### Tcl control utilities.
+
+set CLEANUPS {}
+
+proc with-cleanup {body} {
+ ## Evaluate BODY, which may contain `cleanup' calls. When it finishes,
+ ## evaluate the cleanup bodies, in order.
+
+ global CLEANUPS
+ set save $CLEANUPS
+ set CLEANUPS {}
+ set rc [catch { uplevel 1 $body } result]
+ foreach item $CLEANUPS { uplevel 1 $item }
+ set CLEANUPS $save
+ return -code $rc $result
+}
+
+proc cleanup {body} {
+ ## Arrange to perform BODY at the end of the enclosing `with-cleanup' form.
+
+ global CLEANUPS
+ lappend CLEANUPS $body
+}
+
+###--------------------------------------------------------------------------
+### File system convenience functions.
+
+proc make-directories {mode args} {
+ ## Create the directories named in the ARGS list with the given MODE, and
+ ## with the configured owner and group. Don't use Tcl's file mkdir here,
+ ## because it's potentially racy.
+
+ global C
+ foreach dir $args {
+ exec mkdir -m700 $dir
+ file attributes $dir \
+ -owner $C(ca-owner) -group $C(ca-group) \
+ -permissions $mode
+ }
+}
+
+proc make-file {file contents} {
+ ## Create the FILE with the specified contents.
+
+ set f [open $file "w"]
+ puts -nonewline $f $contents
+ close $f
+}
+
+proc fresh-temp {dir name body} {
+ ## Find a name for a fresh temporary file in DIR; store the chosen name in
+ ## NAME, and evaluate BODY. If BODY succeeds and returns true then all is
+ ## well; if it continues or fails with POSIX EEXIST then try again with a
+ ## different name; otherwise propagate the error.
+
+ global errorCode
+ upvar 1 $name file
+ while 1 {
+ set file [file join $dir \
+ [format "tmp.%s.%d.%d.%06x" \
+ [info hostname] \
+ [pid] \
+ [clock seconds] \
+ [expr {int(rand()*16777216)}]]]
+ set rc [catch {uplevel 1 $body} result]
+ switch $rc {
+ 0 { return $file }
+ 1 {
+ if {[string equal [lrange $errorCode 0 1] "POSIX EEXIST"]} {
+ continue
+ } else {
+ return -code 1 $result
+ }
+ }
+ 2 { return $result }
+ 4 { continue }
+ default { return -code $rc $result }
+ }
+ }
+}
+
+###--------------------------------------------------------------------------
+### SQL chunks.
+
+proc sql {name} {
+ ## Return a named chunk of SQL.
+
+ global CERTROOT
+ set f [open "$CERTROOT/sql/$name.sql"]
+ set sql [read $f]
+ close $f
+ return $sql
+}
+
+###--------------------------------------------------------------------------
+### Date and time handling.
+
+proc now {} {
+ ## Return the current Unix time. Except that the magic environment
+ ## variable CA_FAKE_TIME can be set in order to convince the script that
+ ## some other time should be used instead.
+
+ global env TIME_DELTA
+ set now [clock seconds]
+ if {[info exists env(CA_FAKE_TIME)]} {
+ if {![info exists TIME_DELTA]} {
+ set fake [clock scan $env(CA_FAKE_TIME)]
+ set TIME_DELTA [expr {$fake - $now}]
+ }
+ return [expr {$now + $TIME_DELTA}]
+ } else {
+ return $now
+ }
+}
+
+proc time-db {t} {
+ ## Convert a Unix time into something we should store in the database.
+ ## Currently we use ISO 8601 strings giving UTC times; however, the only
+ ## guarantee made here is that lexical ordering on the time strings is the
+ ## same as the temporal ordering.
+
+ return [clock format $t -timezone :UTC -format "%Y-%m-%dT%H:%M:%SZ"]
+}
+
+proc db-time {s} {
+ ## Convert a time from the database into a Unix time.
+
+ return [clock scan $s -timezone :UTC -format "%Y-%m-%dT%H:%M:%SZ"]
+}
+
+proc time-asn1 {t} {
+ ## Convert a Unix time into a string suitable for passing to OpenSSL as a
+ ## validity time.
+
+ return [clock format $t -timezone :UTC -format "%y%m%d%H%M%SZ"]
+}
+
+proc time-revoke {t} {
+ ## Convert a Unix time into a string suitable for an OpenSSL revocation
+ ## time.
+
+ return [clock format $t -timezone :UTC -format "%Y%m%d%H%M%SZ"]
+}
+
+proc split-date {date} {
+ ## Parse an ISO8601 date or pattern into a list of items. Numbers have
+ ## leading zeroes removed so that they don't smell like octal.
+
+ set list [regexp -inline -expanded {
+ ^ \s*
+ (\d+ | \* | \* / \d+)
+ -
+ (\d+ | \* | \* / \d+)
+ -
+ (\d+ | \* | \* / \d+)
+ (?: \s* T \s* | \s+)
+ (\d+ | \* | \* / \d+)
+ :
+ (\d+ | \* | \* / \d+)
+ :
+ (\d+ | \* | \* / \d+)
+ $
+ } $date]
+ if {![llength $list]} { error "invalid date pattern `$date'" }
+ set out {}
+ foreach item [lrange $list 1 end] {
+ lappend out [regsub {^0*(.)} $item "\\1"]
+ }
+ return $out
+}
+
+proc next-matching-date* {pat refvar i} {
+ ## Adjust the time in REFVAR forwards so that its components I, I + 1,
+ ## ... match the corresponding patterns in PAT: both are lists containing
+ ## year, month, day, hour, minute, second components in that order. If
+ ## this works, return `ok'. Otherwise return `step' as an indication that
+ ## the caller should step its time component and try again.
+ ##
+ ## This function has hideous behaviour with nonsensical patterns. For
+ ## example, searching for `*-02-30 00:00:00' will loop forever.
+
+ ## If we've gone off the end, we're done.
+ if {$i >= 6} { return ok }
+
+ ## Find the caller's reference time.
+ upvar $refvar ref
+
+ ## A useful list of minimum values.
+ set min { 0 1 1 0 0 0 }
+
+ ## Find the maximum value we're allowed in this component.
+ switch $i {
+ 0 { set max [expr {1 << 31}] }
+ 1 { set max 12 }
+ 2 {
+ switch [lindex $ref 1] {
+ 1 - 3 - 5 - 7 - 8 - 10 - 12 { set max 31 }
+ 4 - 6 - 9 - 11 { set max 30 }
+ 2 {
+ set y [lindex $ref 0]
+ if {$y%400 == 0} { set max 29 } \
+ elseif {$y%100 == 0} { set max 28 } \
+ elseif {$y%4 == 0} { set max 29 } \
+ else { set max 28 }
+ }
+ }
+ }
+ 3 { set max 23 }
+ 4 - 5 { set max 59 }
+ }
+
+ ## Collect the pattern and current-value entries.
+ set p [lindex $pat $i]
+ set n [lindex $ref $i]
+ set nn $n
+
+ ## Now for the main job. We try to adjust the current component forwards
+ ## and within its bounds so as to match the pattern. If that fails, return
+ ## `step' immediately. If it succeeds, then recursively process the less
+ ## significant components. If we have to step, then advance by one and try
+ ## again: this will propagate the failure upwards if necessary.
+ while 1 {
+
+ ## Work out what kind of pattern this is and how to deal with it.
+ switch -regexp -matchvar m $p {
+
+ {^\d+$} {
+ ## A numeric literal. If it's within bounds then set it; otherwise
+ ## we'll have to start from the beginning.
+ if {$p < $n || $p > $max} { return step }
+ set nn $p
+ }
+
+ {^\*$} {
+ ## If this is an unqualified wildcard then accept it.
+ }
+
+ {^\*/(\d+)$} {
+ ## If this is a wildcard with a step amount then adjust forwards. If
+ ## we bust then fail.
+ set m [lindex $m 1]
+ set nn [expr {$nn + $m - 1}]
+ set nn [expr {$nn - $nn%$m}]
+ if {$nn > $max} { return step }
+ }
+
+ default {
+ ## It's something else we don't know how to handle.
+ error "bad date pattern `$p'"
+ }
+ }
+
+ ## If we've moved on then clear the less significant entries. This will
+ ## make it easier for them to match. It's also necessary for
+ ## correctness, of course.
+ if {$nn > $n} {
+ for {set j [expr {$i + 1}]} {$j < 6} {incr j} {
+ lset ref $j [lindex $min $j]
+ }
+ }
+
+ ## Write the value back to the reference time, and recursively fix up the
+ ## less significant components.
+ lset ref $i $nn
+ switch [next-matching-date* $pat ref [expr {$i + 1}]] {
+ ok { return ok }
+ step { }
+ default { error "INTERNAL: unexpected rc" }
+ }
+
+ ## It didn't work. Move on by one. This is just to perturb the value:
+ ## the big switch at the top will do the necessary fine tuning.
+ set n [lindex $ref $i]
+ set nn [expr {$n + 1}]
+ }
+}
+
+proc next-matching-date {pat {ref now}} {
+ ## Return the next time (as Unix time) after REF which matches PAT.
+
+ if {[string equal $ref now]} { set ref [now] }
+ set reflist [split-date [clock format $ref -format "%Y-%m-%d %H:%M:%S"]]
+ set patlist [split-date $pat]
+ if {![string equal [next-matching-date* $patlist reflist 0] ok]} {
+ error "failed to find matching date"
+ }
+ return [clock scan \
+ [eval [list format "%04d-%02d-%02d %02d:%02d:%02d"] \
+ $reflist] \
+ -format "%Y-%m-%d %H:%M:%S"]
+}
+
+###--------------------------------------------------------------------------
+### Setting up profiles.
+
+proc sync-profiles {} {
+ ## Synchronize the profiles in the database with the configuration file.
+
+ global P
+ db transaction {
+
+ ## Delete profiles which are no longer wanted.
+ foreach {p t} [db eval { SELECT label, tombstone FROM profile; }] {
+ set rec($p) t
+ if {[info exists P($p)]} {
+ ## We have a matching entry. The tombstone flag may be set, but we
+ ## will turn that off in the second pass.
+ continue
+ } elseif {![db exists { SELECT 1 FROM request WHERE profile = $p; }]} {
+ ## No references, so we can delete the entry.
+ db eval { DELETE FROM profile WHERE label = $p; }
+ } elseif {!$t} {
+ ## There are still references, and the tombstone flag isn't set yet.
+ ## Set it.
+ db eval { UPDATE profile SET tombstone = 1 WHERE label = $p; }
+ }
+ }
+
+ ## Now push each defined profile into the database. This may cause
+ ## redundant updates, but I don't really care.
+ foreach {p dict} [array get P] {
+ array unset d
+ array set d $dict
+ if {[info exists rec($p)]} {
+ db eval {
+ UPDATE profile SET
+ extensions = $d(extensions),
+ issue_time = $d(issue-time),
+ start_skew = $(start-skew),
+ expire_interval = $d(expire-interval),
+ tombstone = 0
+ WHERE label = $p;
+ }
+ } else {
+ db eval {
+ INSERT INTO profile(label, extensions, issue_time,
+ start_skew, expire_interval)
+ VALUES ($p, $d(extensions), $d(issue-time),
+ $d(start-skew), $d(expire-interval));
+ }
+ }
+ }
+ }
+}
+
+###--------------------------------------------------------------------------
+### Extracting information from request and certificate files.
+
+proc req-key-hash {file} {
+ ## Return the key hash from the certificate request in FILE.
+
+ return [exec \
+ openssl req -in $file -noout -pubkey | \
+ openssl rsa 2>/dev/null -pubin -outform der | \
+ openssl dgst -sha256 -hex]
+}
+
+proc req-dn {file} {
+ ## Return the distinguished name from the certificate request in FILE.
+
+ regexp {^subject=\s*(/.*)$} \
+ [exec openssl req -in $file -noout -subject] \
+ -> dn
+ return $dn
+}
+
+proc cert-key-hash {file} {
+ ## Return the key hash from the certificate in FILE.
+
+ return [exec \
+ openssl x509 -in $file -noout -pubkey | \
+ openssl rsa 2>/dev/null -pubin -outform der | \
+ openssl dgst -sha256 -hex]
+}
+
+proc cert-dn {file} {
+ ## Return the distinguished name from the certificate in FILE.
+
+ regexp {^subject=\s*(/.*)$} \
+ [exec openssl x509 -in $file -noout -subject] \
+ -> dn
+ return $dn
+}
+
+proc cert-seq {file} {
+ ## Return the serial number of the certificate in FILE.
+
+ regexp {^serial\s*=\s*([0-9a-fA-F]+)$} \
+ [exec openssl x509 -noout -serial -in $file] \
+ -> serial
+ return [expr 0x$serial + 0]
+}
+
+###--------------------------------------------------------------------------
+### Certificate requests.
+
+proc request-match {reqid cond} {
+ ## Return a list of request-ids which match REQID and satisfy COND. The
+ ## REQID may be a numerical id, a SQL `LIKE' pattern matched against
+ ## request tags, or the special token `-all'. The COND is a SQL boolean
+ ## expression. The expression is /ignored/ if the REQID is an explicit
+ ## request id.
+
+ set conds {}
+ set win false
+
+ ## Set up the `conds' list to a bunch of SQL expressions we'll try.
+ if {[string equal $reqid "-all"]} {
+ set conds [list $cond]
+ set win true
+ } else {
+ if {[string is digit $reqid]} { lappend conds "id = :reqid" }
+ lappend conds "tag LIKE :reqid AND $cond"
+ }
+
+ ## See if any of the expressions match.
+ foreach c $conds {
+ set reqs [db eval "SELECT id FROM request WHERE $c;"]
+ if {[llength $reqs] > 0} { set win true; break }
+ }
+ if {!$win} {
+ error "no requests match `$reqid'"
+ }
+
+ ## Done.
+ return $reqs
+}
+
+###--------------------------------------------------------------------------
+### Archival.
+
+## Archive format.
+##
+## The archive consists of the following files.
+##
+## cert.SEQ certificate storage
+## req.ID request storage
+## openssl-certs.txt OpenSSL records for the certificates
+## certificate.dump certificate records from the database
+## request.dump request records from the database
+##
+## The `openssl-certs.txt' file contains lines from the `state.db' file
+## referring to the archived certificates. The `.dump' files contain
+## Tcl-format plists suitable for passing to `array set' mapping database
+## fields to values.
+
+proc archive-certificates {} {
+ ## Archive any certificates and certificate requests which need it.
+
+ global CERTROOT C
+
+ db transaction {
+
+ ## Initial setup.
+ set when [time-db [expr {[now] - 86400*$C(archive-interval)}]]
+ array unset archcerts
+ set archfiles {}
+ set delfiles {}
+
+ ## Prepare the archive staging area.
+ cd $CERTROOT
+ set archdir "tmp/arch"
+ file delete -force $archdir
+ file delete -force "tmp/arch.tgz"
+ file mkdir $archdir
+
+ ## Dig out the certificates.
+ set anycert false
+ with-cleanup {
+ set out [open "$archdir/certificate.dump" w]
+ cleanup { close $out }
+ db eval {
+ SELECT * FROM certificate
+ WHERE t_expire <= $when;
+ } R {
+ set line {}
+ foreach i $R(*) { lappend line $i $R($i) }
+ puts $out $line
+ set anycert true
+ set archcerts($R(seq)) 1
+ file link -hard "$archdir/cert.$R(seq)" "cert/by-seq/$R(seq)"
+ lappend archfiles "cert.$R(seq)"
+ lappend delfiles "cert/by-seq/$R(seq)"
+ }
+ }
+
+ ## Prune the OpenSSL request file.
+ if {$anycert} {
+ with-cleanup {
+ set in [open "state/db"]
+ cleanup { close $in }
+ set arch [open "$archdir/openssl-certs.txt" "w"]
+ cleanup { close $arch }
+ set new [open "state/db.new" "w"]
+ cleanup { close $new }
+
+ while {[gets $in line] >= 0} {
+ set seq [expr 0x[lindex [split $line "\t"] 3] + 0]
+ puts [expr {[info exists archcerts($seq)] ? $arch : $new}] $line
+ }
+ }
+ lappend archfiles "openssl-certs.txt" "certificate.dump"
+ }
+
+ ## Delete the certificates that we archived. Here we rely on SQLite's
+ ## strong isolation guarantees to ensure that the DELETE query here
+ ## matches the same records as the SELECT did above. Also, we rely on
+ ## SQLite rolling back if anything goes wrong in the rest of the job.
+ ## This is considerably simpler than fiddling the queries below to look
+ ## at the expiry dates of matching certificates.
+ db eval {
+ DELETE FROM certificate
+ WHERE t_expire <= $when;
+ }
+
+ ## Find the orphaned requests. Don't clobber active requests even if
+ ## they look orphaned: we might just have failed to create certificates
+ ## for them for some reason.
+ set anyreq false
+ with-cleanup {
+ set out [open "$archdir/request.dump" w]
+ cleanup { close $out }
+ db eval {
+ SELECT r.*
+ FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
+ WHERE c.req IS NULL AND r.st != 'active';
+ } R {
+ set line {}
+ foreach i $R(*) { lappend line $i $R($i) }
+ puts $out $line
+ set anyreq true
+ file link -hard "$archdir/req.$R(id)" "req/by-id/$R(id)"
+ lappend archfiles "req.$R(id)"
+ lappend delfiles "req/by-id/$R(id)"
+ }
+ }
+ if {$anyreq} { lappend archfiles "request.dump" }
+
+ ## Make the archive.
+ if {!$anycert && !$anyreq} { return }
+ cd $archdir
+ eval exec tar cfz "../arch.tgz" $archfiles
+
+ ## Delete the requests that we archived. Again we rely on SQLite's
+ ## strong isolation to avoid races.
+ db eval {
+ DELETE FROM request
+ WHERE id IN (
+ SELECT r.id
+ FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
+ WHERE c.req IS NULL AND r.st != 'active');
+ }
+
+ ## Tidy everything up.
+ cd $CERTROOT
+ set t [time-db [now]]
+ file rename "tmp/arch.tgz" "archive/$t.tgz"
+ if {$anycert} { file rename -force "state/db.new" "state/db" }
+ }
+ foreach f $delfiles { file delete $f }
+ file delete -force $archdir
+ file delete -force "tmp/arch.tgz"
+}
+
+###--------------------------------------------------------------------------
+### Certificate revocation.
+
+## Enormous table of revocation reasons and how to handle them.
+array set REVOKE_REASON {
+ unspecified {
+ unspecified
+ none
+ }
+ key-compromise {
+ keyCompromise
+ time "%Y%m%d%H%M%SZ"
+ -crl_compromise
+ }
+ ca-compromise {
+ CACompromise
+ time "%Y%m%d%H%M%SZ"
+ -crl_CA_compromise
+ }
+ affiliation-changed {
+ affiliationChanged
+ none
+ }
+ superceded {
+ superseded
+ none
+ }
+ cessation-of-operation {
+ cessationOfOperation
+ none
+ }
+ remove-from-crl {
+ removeFromCrl
+ none
+ }
+ certificate-hold {
+ certificateHold
+ enum {
+ reject holdInstructionReject
+ none holdInstructionNone
+ call-issuer holdInstructionCallIssuer
+ }
+ -crl_hold
+ }
+}
+
+proc revoke-reason-info {reason infovar} {
+ ## Write information about the revocation REASON into the array INFOVAR.
+ ## The keys defined for INFOVAR are as follows.
+ ##
+ ## reason The provided reason string.
+ ## oid The OID name for the reason.
+ ## detail-type The type of the detail (for converting details).
+ ## detail-info Additional information for detail conversion
+ ## detail-arg The OpenSSL detail argument name.
+
+ global REVOKE_REASON
+ upvar 1 $infovar R
+
+ if {![info exists REVOKE_REASON($reason)]} {
+ error "unknown revocation reason `$reason'"
+ }
+
+ array unset R
+ set R(reason) $reason
+ lassign $REVOKE_REASON($reason) \
+ R(oid) R(detail-type) R(detail-info) R(detail-arg)
+}
+
+proc revoke-parse-detail/none {info detail} {
+ if {[llength $detail] > 0} {
+ error "no detail permitted"
+ }
+ return nil
+}
+
+proc revoke-openssl-args/none {info arg detail} {
+ return {}
+}
+
+proc revoke-parse-detail/time {info detail} {
+ switch [llength $detail] {
+ 0 { set t [now] }
+ 1 { set t [clock scan [lindex $detail 0]] }
+ default { error "too many time arguments" }
+ }
+ return [time-db $t]
+}
+
+proc revoke-openssl-args/time {info arg detail} {
+ return [list $arg [clock format [db-time $detail] \
+ -timezone :UTC \
+ -format $info]]
+}
+
+proc revoke-parse-detail/enum {info detail} {
+ switch [llength $detail] {
+ 0 { set r [lindex $info 0] }
+ 1 {
+ array set M $info
+ set r [lindex $detail 0]
+ if {![info exists M($r)]} { error "invalid detail value `$r'" }
+ }
+ default { error "too many symbolic arguments" }
+ }
+ return $r
+}
+
+proc revoke-openssl-args/enum {info arg detail} {
+ array set M $info
+ return [list $arg $M($detail)]
+}
+
+proc revoke-parse-detail {infovar detail} {
+ ## Parse a revocation detail, as provided in a command-line argument list,
+ ## and convert it into the database format.
+
+ upvar 1 $infovar R
+ return [revoke-parse-detail/$R(detail-type) $R(detail-info) $detail]
+}
+
+proc revoke-openssl-args {infovar detail} {
+ ## Return OpenSSL arguments for revoking certificates, given a revocation
+ ## DETAIL. You need to provide the `-revoke FILE' bit yourself: this only
+ ## provides the `-crl_reason REASON' and detail arguments.
+
+ upvar 1 $infovar R
+ return [concat \
+ [list -crl_reason $R(oid)] \
+ [revoke-openssl-args/$R(detail-type) \
+ $R(detail-info) $R(detail-arg) $detail]]
+}
+
+proc revoke-requests {infovar detail reqs} {
+ ## Revoke a bunch of certificate requests, listed by id in REQS. The
+ ## INFOVAR is the name of an array set up by `revoke-reason-info'; the
+ ## DETAIL is the revocation detail in internal format, e.g., as established
+ ## by `revoke-parse-detail'.
+ ##
+ ## This function establishes its own transaction, but you should wrap it in
+ ## your own one if you found the REQS list as a result of a database query,
+ ## in order to avoid race conditions.
+
+ ## Find some useful things.
+ global env
+ upvar 1 $infovar R
+ set ossl_args [revoke-openssl-args R $detail]
+ set del {}
+
+ ## Wrap a transaction around, so that we can reset the database if
+ ## something goes wrong with the file fiddling half-way through.
+ db transaction {
+
+ ## Make a copy of the state database. We'll work on that using some
+ ## unpleasant configuration hacking.
+ file copy -force "state/db" "state/db.revoke"
+ set env(db_suffix) ".revoke"
+
+ ## Now work through the requests one by one, revoking each affected
+ ## certificate.
+ foreach req $reqs {
+
+ ## Check the request state. If it was previously active, we must
+ ## remember to delete the link. Obviously we shouldn't actually delete
+ ## them yet, because this might fail catastrophically.
+ lassign [db eval { SELECT st, tag FROM request WHERE id = $req; }] \
+ reqst tag
+ if {[string equal $reqst active]} { lappend del "req/active/$tag" }
+
+ ## Now try the certificates.
+ foreach {cert certst} [db eval {
+ SELECT seq, st FROM certificate
+ WHERE req = $req AND st != 'expired';
+ }] {
+
+ ## Check the certificate state: again, we might have to delete the
+ ## active link.
+ if {[string equal $certst active]} { lappend del "cert/active/$tag" }
+
+ ## Update the certificate state.
+ db eval { UPDATE certificate SET st = 'revoked' WHERE seq = $cert; }
+
+ ## Get OpenSSL to update its database.
+ eval exec openssl ca \
+ [list -config "etc/openssl.conf"] \
+ [list -revoke "cert/by-seq/$cert"] \
+ $ossl_args \
+ 2>@1
+ }
+
+ ## Finally fiddle the request state.
+ db eval {
+ UPDATE request
+ SET st = 'revoked',
+ revoke_reason = $R(reason),
+ revoke_detail = $detail
+ WHERE id = $req;
+ }
+ }
+
+ ## Astonishingly all of that actually worked.
+ file rename -force "state/db.revoke" "state/db"
+ }
+
+ ## Delete the active links we made a note of earlier.
+ foreach f $del { file delete -force $f }
+}
+
+###--------------------------------------------------------------------------
+### Managing certificates.
+
+proc issue-cert {id now} {
+ ## Issue a certificate for the request with the given ID. This doesn't
+ ## bother to find out whethere it's a good idea.
+
+ global CERTROOT
+ db nullvalue nil
+
+ with-cleanup {
+ db transaction {
+
+ ## Find a temporary file name for the output certificate.
+ fresh-temp "$CERTROOT/tmp" tmp {
+ set f [open $tmp {WRONLY CREAT EXCL}]
+ }
+ cleanup { file delete $tmp }
+ close $f
+
+ ## Find stuff out about the request.
+ lassign [db eval {
+ SELECT p.start_skew, p.expire_interval, p.issue_time, p.extensions,
+ r.tag, r.cert_dn
+ FROM request AS r JOIN
+ profile AS p ON r.profile = p.label
+ WHERE r.id = $id;
+ }] start_skew expire_interval issue_time extensions tag cert_dn
+
+ ## Sign the certificate.
+ set starttime [expr {$now - 3600*$start_skew}]
+ set endtime [expr {$now + 3600*$expire_interval}]
+ cleanup { catch { eval file delete [glob "$CERTROOT/tmp/*.pem"] } }
+ exec openssl ca -batch \
+ -config "$CERTROOT/etc/openssl.conf" \
+ -outdir "$CERTROOT/tmp" \
+ -extensions $extensions \
+ -startdate [time-asn1 $starttime] \
+ -enddate [time-asn1 $endtime] \
+ -in "$CERTROOT/req/by-id/$id" -out $tmp \
+ 2>@1
+
+ ## Update the request's cert_dn field. If it's null, this is the first
+ ## certificate issued for the request, and we should fill the field in;
+ ## otherwise we should compare the actual DN to the expected one and
+ ## fail if it's wrong.
+ set dn [cert-dn $tmp]
+ if {[string equal $cert_dn nil]} {
+ db eval { UPDATE request SET cert_dn = $dn WHERE id = $id; }
+ } elseif {![string equal $cert_dn $dn]} {
+ error [join {
+ "DN mismatch: request $id (`$tag') has $cert_dn; "
+ "new cert has $dn"} ""]
+ }
+
+ ## Stash a new record in the database.
+ set expire [time-db $endtime]
+ set next_issue [time-db [next-matching-date $issue_time $now]]
+ set now_db [time-db $now]
+ set seq [cert-seq $tmp]
+ db eval {
+ UPDATE certificate
+ SET st = CASE WHEN t_expire >= $now_db THEN 'superceded'
+ ELSE 'expired'
+ END
+ WHERE req = $id AND st = 'active';
+
+ INSERT INTO certificate(seq, req, st, t_expire)
+ VALUES ($seq, $id, 'active', $expire);
+
+ UPDATE request SET t_reissue = $next_issue
+ WHERE id = $id;
+ }
+
+ ## Put the file in the right place.
+ file link -hard "$CERTROOT/cert/by-seq/$seq" $tmp
+ exec ln -sf "../by-seq/$seq" "$CERTROOT/cert/active/$tag"
+ }
+ }
+}
+
+proc expire-certs {now} {
+ ## Mark certificates as having expired.
+
+ global CERTROOT
+ set now_db [time-db $now]
+
+ ## If we're unlucky, some active certificates may have expired while we
+ ## weren't looking. We'll demote these soon, but we must clear away the
+ ## old links.
+ foreach tag [db eval {
+ SELECT r.tag
+ FROM request AS r JOIN certificate as c ON r.id = c.req
+ WHERE c.st = 'active' AND c.t_expire < $now_db;
+ }] {
+ file delete "$CERTROOT/cert/active/$tag"
+ }
+
+ ## Now demote the states of expired certificates. All certificates expire,
+ ## including revoked ones.
+ db eval {
+ UPDATE certificate
+ SET st = 'expired'
+ WHERE st != 'expired' AND t_expire < $now_db;
+ }
+}
+
+###----- That's all, folks --------------------------------------------------
~mdw / ca / blobdiff