Almost a complete rewrite.

[ca] / lib / func.tcl

### -*-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 --------------------------------------------------