chiark - git - mdw - ca/blob - lib/func.tcl

   1 ### -*-tcl-*-
   2 ###
   3 ### Common functions for certificate management.
   4 ###
   5 ### (c) 2011 Mark Wooding
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This program is free software; you can redistribute it and/or modify
  11 ### it under the terms of the GNU General Public License as published by
  12 ### the Free Software Foundation; either version 2 of the License, or
  13 ### (at your option) any later version.
  14 ###
  15 ### This program is distributed in the hope that it will be useful,
  16 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ### GNU General Public License for more details.
  19 ###
  20 ### You should have received a copy of the GNU General Public License
  21 ### along with this program; if not, write to the Free Software Foundation,
  22 ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 package require sqlite3
  25
  26 ###--------------------------------------------------------------------------
  27 ### Command line conventions.
  28
  29 set QUIS [file tail $argv0]
  30 set RC 0
  31
  32 proc moan {message} {
  33   ## Report MESSAGE as a warning message.
  34
  35   global QUIS
  36   puts stderr "$QUIS: $message"
  37 }
  38
  39 proc bad {level message} {
  40   ## Report an error MESSAGE at badness LEVEL.
  41
  42   global RC
  43   if {$level > $RC} { set RC $level }
  44   moan $message
  45 }
  46
  47 proc quit {} {
  48   ## Exit the program.
  49
  50   global RC
  51   exit $RC
  52 }
  53
  54 proc die {message} {
  55   ## Report an error MESSAGE and quit.
  56
  57   bad 1 $message
  58   quit
  59 }
  60
  61 ###--------------------------------------------------------------------------
  62 ### Find and read configuration.
  63
  64 set CERTROOT [file normalize [file dirname [file dirname [info script]]]]
  65
  66 ## Default user configuration.
  67 set C(ca-owner) "root"
  68 set C(ca-user) "ca"
  69 set C(ca-group) "ca"
  70
  71 ## CA distinguished name.
  72 set C(ca-name) {
  73   countryName "GB"
  74   stateOrProvinceName "Borsetshire"
  75   localityName "Ambridge"
  76   organizationName "Archers' Omnibus Company"
  77   organizationalUnitName "Certificate Authority"
  78   commonName "Archers Omnibus Certificate Authority"
  79   emailAddress "eddie.grundy@archers.example.com"
  80 }
  81
  82 ## Profiles.
  83 array unset P
  84
  85 ## Other random configuration.
  86 set C(ca-period) 3650
  87 set C(archive-interval) 32
  88
  89 ## The update hook function.
  90 proc update-hook {} {
  91   ## Called by `bin/update': might publish data to a web server, for example.
  92 }
  93
  94 ## Read the user configuration.
  95 if {[file exists "$CERTROOT/etc/config.tcl"]} {
  96   source "$CERTROOT/etc/config.tcl"
  97 }
  98
  99 ###--------------------------------------------------------------------------
 100 ### Tcl control utilities.
 101
 102 set CLEANUPS {}
 103
 104 proc with-cleanup {body} {
 105   ## Evaluate BODY, which may contain `cleanup' calls.  When it finishes,
 106   ## evaluate the cleanup bodies, in order.
 107
 108   global CLEANUPS
 109   set save $CLEANUPS
 110   set CLEANUPS {}
 111   set rc [catch { uplevel 1 $body } result]
 112   foreach item $CLEANUPS { uplevel 1 $item }
 113   set CLEANUPS $save
 114   return -code $rc $result
 115 }
 116
 117 proc cleanup {body} {
 118   ## Arrange to perform BODY at the end of the enclosing `with-cleanup' form.
 119
 120   global CLEANUPS
 121   lappend CLEANUPS $body
 122 }
 123
 124 ###--------------------------------------------------------------------------
 125 ### File system convenience functions.
 126
 127 proc make-directories {mode args} {
 128   ## Create the directories named in the ARGS list with the given MODE, and
 129   ## with the configured owner and group.  Don't use Tcl's file mkdir here,
 130   ## because it's potentially racy.
 131
 132   global C
 133   foreach dir $args {
 134     exec mkdir -m700 $dir
 135     file attributes $dir \
 136         -owner $C(ca-owner) -group $C(ca-group) \
 137         -permissions $mode
 138   }
 139 }
 140
 141 proc make-file {file contents} {
 142   ## Create the FILE with the specified contents.
 143
 144   set f [open $file "w"]
 145   puts -nonewline $f $contents
 146   close $f
 147 }
 148
 149 proc fresh-temp {dir name body} {
 150   ## Find a name for a fresh temporary file in DIR; store the chosen name in
 151   ## NAME, and evaluate BODY.  If BODY succeeds and returns true then all is
 152   ## well; if it continues or fails with POSIX EEXIST then try again with a
 153   ## different name; otherwise propagate the error.
 154
 155   global errorCode
 156   upvar 1 $name file
 157   while 1 {
 158     set file [file join $dir \
 159                   [format "tmp.%s.%d.%d.%06x" \
 160                        [info hostname] \
 161                        [pid] \
 162                        [clock seconds] \
 163                        [expr {int(rand()*16777216)}]]]
 164     set rc [catch {uplevel 1 $body} result]
 165     switch $rc {
 166       0 { return $file }
 167       1 {
 168         if {[string equal [lrange $errorCode 0 1] "POSIX EEXIST"]} {
 169           continue
 170         } else {
 171           return -code 1 $result
 172         }
 173       }
 174       2 { return $result }
 175       4 { continue }
 176       default { return -code $rc $result }
 177     }
 178   }
 179 }
 180
 181 ###--------------------------------------------------------------------------
 182 ### SQL chunks.
 183
 184 proc sql {name} {
 185   ## Return a named chunk of SQL.
 186
 187   global CERTROOT
 188   set f [open "$CERTROOT/sql/$name.sql"]
 189   set sql [read $f]
 190   close $f
 191   return $sql
 192 }
 193
 194 ###--------------------------------------------------------------------------
 195 ### Date and time handling.
 196
 197 proc now {} {
 198   ## Return the current Unix time.  Except that the magic environment
 199   ## variable CA_FAKE_TIME can be set in order to convince the script that
 200   ## some other time should be used instead.
 201
 202   global env TIME_DELTA
 203   set now [clock seconds]
 204   if {[info exists env(CA_FAKE_TIME)]} {
 205     if {![info exists TIME_DELTA]} {
 206       set fake [clock scan $env(CA_FAKE_TIME)]
 207       set TIME_DELTA [expr {$fake - $now}]
 208     }
 209     return [expr {$now + $TIME_DELTA}]
 210   } else {
 211     return $now
 212   }
 213 }
 214
 215 proc time-db {t} {
 216   ## Convert a Unix time into something we should store in the database.
 217   ## Currently we use ISO 8601 strings giving UTC times; however, the only
 218   ## guarantee made here is that lexical ordering on the time strings is the
 219   ## same as the temporal ordering.
 220
 221   return [clock format $t -timezone :UTC -format "%Y-%m-%dT%H:%M:%SZ"]
 222 }
 223
 224 proc db-time {s} {
 225   ## Convert a time from the database into a Unix time.
 226
 227   return [clock scan $s -timezone :UTC -format "%Y-%m-%dT%H:%M:%SZ"]
 228 }
 229
 230 proc time-asn1 {t} {
 231   ## Convert a Unix time into a string suitable for passing to OpenSSL as a
 232   ## validity time.
 233
 234   return [clock format $t -timezone :UTC -format "%y%m%d%H%M%SZ"]
 235 }
 236
 237 proc time-revoke {t} {
 238   ## Convert a Unix time into a string suitable for an OpenSSL revocation
 239   ## time.
 240
 241   return [clock format $t -timezone :UTC -format "%Y%m%d%H%M%SZ"]
 242 }
 243
 244 proc split-date {date} {
 245   ## Parse an ISO8601 date or pattern into a list of items.  Numbers have
 246   ## leading zeroes removed so that they don't smell like octal.
 247
 248   set list [regexp -inline -expanded {
 249     ^ \s*
 250     (\d+ | \* | \* / \d+)
 251     -
 252     (\d+ | \* | \* / \d+)
 253     -
 254     (\d+ | \* | \* / \d+)
 255     (?: \s* T \s* | \s+)
 256     (\d+ | \* | \* / \d+)
 257     :
 258     (\d+ | \* | \* / \d+)
 259     :
 260     (\d+ | \* | \* / \d+)
 261     $
 262   } $date]
 263   if {![llength $list]} { error "invalid date pattern `$date'" }
 264   set out {}
 265   foreach item [lrange $list 1 end] {
 266     lappend out [regsub {^0*(.)} $item "\\1"]
 267   }
 268   return $out
 269 }
 270
 271 proc next-matching-date* {pat refvar i} {
 272   ## Adjust the time in REFVAR forwards so that its components I, I + 1,
 273   ## ... match the corresponding patterns in PAT: both are lists containing
 274   ## year, month, day, hour, minute, second components in that order.  If
 275   ## this works, return `ok'.  Otherwise return `step' as an indication that
 276   ## the caller should step its time component and try again.
 277   ##
 278   ## This function has hideous behaviour with nonsensical patterns.  For
 279   ## example, searching for `*-02-30 00:00:00' will loop forever.
 280
 281   ## If we've gone off the end, we're done.
 282   if {$i >= 6} { return ok }
 283
 284   ## Find the caller's reference time.
 285   upvar $refvar ref
 286
 287   ## A useful list of minimum values.
 288   set min { 0 1 1 0 0 0 }
 289
 290   ## Find the maximum value we're allowed in this component.
 291   switch $i {
 292     0 { set max [expr {1 << 31}] }
 293     1 { set max 12 }
 294     2 {
 295       switch [lindex $ref 1] {
 296         1 - 3 - 5 - 7 - 8 - 10 - 12 { set max 31 }
 297         4 - 6 - 9 - 11 { set max 30 }
 298         2 {
 299           set y [lindex $ref 0]
 300           if {$y%400 == 0} { set max 29 } \
 301           elseif {$y%100 == 0} { set max 28 } \
 302           elseif {$y%4 == 0} { set max 29 } \
 303           else { set max 28 }
 304         }
 305       }
 306     }
 307     3 { set max 23 }
 308     4 - 5 { set max 59 }
 309   }
 310
 311   ## Collect the pattern and current-value entries.
 312   set p [lindex $pat $i]
 313   set n [lindex $ref $i]
 314   set nn $n
 315
 316   ## Now for the main job.  We try to adjust the current component forwards
 317   ## and within its bounds so as to match the pattern.  If that fails, return
 318   ## `step' immediately.  If it succeeds, then recursively process the less
 319   ## significant components.  If we have to step, then advance by one and try
 320   ## again: this will propagate the failure upwards if necessary.
 321   while 1 {
 322
 323     ## Work out what kind of pattern this is and how to deal with it.
 324     switch -regexp -matchvar m $p {
 325
 326       {^\d+$} {
 327         ## A numeric literal.  If it's within bounds then set it; otherwise
 328         ## we'll have to start from the beginning.
 329         if {$p < $nn || $p > $max} { return step }
 330         set nn $p
 331       }
 332
 333       {^\*$} {
 334         ## If this is an unqualified wildcard then accept it.
 335       }
 336
 337       {^\*/(\d+)$} {
 338         ## If this is a wildcard with a step amount then adjust forwards.  If
 339         ## we bust then fail.
 340         set m [lindex $m 1]
 341         set nn [expr {$nn + $m - 1}]
 342         set nn [expr {$nn - $nn%$m}]
 343         if {$nn > $max} { return step }
 344       }
 345
 346       default {
 347         ## It's something else we don't know how to handle.
 348         error "bad date pattern `$p'"
 349       }
 350     }
 351
 352     ## If we've moved on then clear the less significant entries.  This will
 353     ## make it easier for them to match.  It's also necessary for
 354     ## correctness, of course.
 355     if {$nn > $n} {
 356       for {set j [expr {$i + 1}]} {$j < 6} {incr j} {
 357         lset ref $j [lindex $min $j]
 358       }
 359     }
 360
 361     ## Write the value back to the reference time, and recursively fix up the
 362     ## less significant components.
 363     lset ref $i $nn
 364     switch [next-matching-date* $pat ref [expr {$i + 1}]] {
 365       ok { return ok }
 366       step { }
 367       default { error "INTERNAL: unexpected rc" }
 368     }
 369
 370     ## It didn't work.  Move on by one.  This is just to perturb the value:
 371     ## the big switch at the top will do the necessary fine tuning.
 372     set n [lindex $ref $i]
 373     set nn [expr {$n + 1}]
 374   }
 375 }
 376
 377 proc next-matching-date {pat {ref now}} {
 378   ## Return the next time (as Unix time) after REF which matches PAT.
 379
 380   if {[string equal $ref now]} { set ref [now] }
 381   set reflist [split-date [clock format $ref -format "%Y-%m-%d %H:%M:%S"]]
 382   set patlist [split-date $pat]
 383   if {![string equal [next-matching-date* $patlist reflist 0] ok]} {
 384     error "failed to find matching date"
 385   }
 386   return [clock scan \
 387               [eval [list format "%04d-%02d-%02d %02d:%02d:%02d"] \
 388                    $reflist] \
 389               -format "%Y-%m-%d %H:%M:%S"]
 390 }
 391
 392 ###--------------------------------------------------------------------------
 393 ### Setting up profiles.
 394
 395 proc sync-profiles {} {
 396   ## Synchronize the profiles in the database with the configuration file.
 397
 398   global P
 399   db transaction {
 400
 401     ## Delete profiles which are no longer wanted.
 402     foreach {p t} [db eval { SELECT label, tombstone FROM profile; }] {
 403       set rec($p) t
 404       if {[info exists P($p)]} {
 405         ## We have a matching entry.  The tombstone flag may be set, but we
 406         ## will turn that off in the second pass.
 407         continue
 408       } elseif {![db exists { SELECT 1 FROM request WHERE profile = $p; }]} {
 409         ## No references, so we can delete the entry.
 410         db eval { DELETE FROM profile WHERE label = $p; }
 411       } elseif {!$t} {
 412         ## There are still references, and the tombstone flag isn't set yet.
 413         ## Set it.
 414         db eval { UPDATE profile SET tombstone = 1 WHERE label = $p; }
 415       }
 416     }
 417
 418     ## Now push each defined profile into the database.  This may cause
 419     ## redundant updates, but I don't really care.
 420     foreach {p dict} [array get P] {
 421       array unset d
 422       array set d $dict
 423       if {[info exists rec($p)]} {
 424         db eval {
 425           UPDATE profile SET
 426                   extensions = $d(extensions),
 427                   issue_time = $d(issue-time),
 428                   start_skew = $d(start-skew),
 429                   expire_interval = $d(expire-interval),
 430                   tombstone = 0
 431           WHERE label = $p;
 432         }
 433       } else {
 434         db eval {
 435           INSERT INTO profile(label, extensions, issue_time,
 436                               start_skew, expire_interval)
 437           VALUES ($p, $d(extensions), $d(issue-time),
 438                   $d(start-skew), $d(expire-interval));
 439         }
 440       }
 441     }
 442   }
 443 }
 444
 445 ###--------------------------------------------------------------------------
 446 ### Extracting information from request and certificate files.
 447
 448 proc req-key-hash {file} {
 449   ## Return the key hash from the certificate request in FILE.
 450
 451   return [lindex [exec \
 452               openssl req -in $file -noout -pubkey | \
 453               openssl rsa 2>/dev/null -pubin -outform der | \
 454               openssl dgst -sha256 -hex] end]
 455 }
 456
 457 proc hack-openssl-dn {out} {
 458   ## Convert OpenSSL's hopeless output into a DN.
 459
 460   if {[regexp {^subject=\s*(/.*)$} $out -> dn]} { return $dn }
 461   if {[regexp {^subject=(.*)$} $out -> t]} {
 462     set t [regsub {^(\w+) = } $t {/\1=}]
 463     set t [regsub -all {, (\w+) = } $t {/\1=}]
 464     return $t
 465   }
 466 }
 467
 468 proc req-dn {file} {
 469   ## Return the distinguished name from the certificate request in FILE.
 470
 471   return [hack-openssl-dn [exec openssl req -in $file -noout -subject]]
 472 }
 473
 474 proc cert-key-hash {file} {
 475   ## Return the key hash from the certificate in FILE.
 476
 477   return [lindex [exec \
 478               openssl x509 -in $file -noout -pubkey | \
 479               openssl rsa 2>/dev/null -pubin -outform der | \
 480               openssl dgst -sha256 -hex] end]
 481 }
 482
 483 proc cert-dn {file} {
 484   ## Return the distinguished name from the certificate in FILE.
 485
 486   return [hack-openssl-dn [exec openssl x509 -in $file -noout -subject]]
 487 }
 488
 489 proc cert-seq {file} {
 490   ## Return the serial number of the certificate in FILE.
 491
 492   regexp {^serial\s*=\s*([0-9a-fA-F]+)$} \
 493       [exec openssl x509 -noout -serial -in $file] \
 494       -> serial
 495   return [expr 0x$serial + 0]
 496 }
 497
 498 ###--------------------------------------------------------------------------
 499 ### Generating the root key.
 500
 501 proc generate-root-key {} {
 502   global C
 503
 504   set subject ""
 505   foreach {attr value} $C(ca-name) { append subject "/$attr=$value" }
 506   exec >@stdout 2>@stderr openssl req -config "etc/openssl.conf"  \
 507       -text -out "ca.cert" -keyout "private/ca.key" \
 508       -new -x509 -days $C(ca-period) \
 509       -subj $subject
 510   file attributes "private/ca.key" \
 511       -owner $C(ca-owner) -group $C(ca-group) \
 512       -permissions 0640
 513   file attributes "ca.cert" \
 514       -owner $C(ca-owner) -group $C(ca-group) \
 515       -permissions 0644
 516 }
 517
 518 ###--------------------------------------------------------------------------
 519 ### Certificate requests.
 520
 521 proc request-match {reqid cond} {
 522   ## Return a list of request-ids which match REQID and satisfy COND.  The
 523   ## REQID may be a numerical id, a SQL `LIKE' pattern matched against
 524   ## request tags, or the special token `-all'.  The COND is a SQL boolean
 525   ## expression.  The expression is /ignored/ if the REQID is an explicit
 526   ## request id.
 527
 528   set conds {}
 529   set win false
 530
 531   ## Set up the `conds' list to a bunch of SQL expressions we'll try.
 532   if {[string equal $reqid "-all"]} {
 533     set conds [list $cond]
 534     set win true
 535   } else {
 536     if {[string is digit $reqid]} { lappend conds "id = :reqid" }
 537     lappend conds "tag LIKE :reqid AND $cond"
 538   }
 539
 540   ## See if any of the expressions match.
 541   foreach c $conds {
 542     set reqs [db eval "SELECT id FROM request WHERE $c;"]
 543     if {[llength $reqs] > 0} { set win true; break }
 544   }
 545   if {!$win} {
 546     error "no requests match `$reqid'"
 547   }
 548
 549   ## Done.
 550   return $reqs
 551 }
 552
 553 ###--------------------------------------------------------------------------
 554 ### Archival.
 555
 556 ## Archive format.
 557 ##
 558 ## The archive consists of the following files.
 559 ##
 560 ## cert.SEQ             certificate storage
 561 ## req.ID               request storage
 562 ## openssl-certs.txt    OpenSSL records for the certificates
 563 ## certificate.dump     certificate records from the database
 564 ## request.dump         request records from the database
 565 ##
 566 ## The `openssl-certs.txt' file contains lines from the `state.db' file
 567 ## referring to the archived certificates.  The `.dump' files contain
 568 ## Tcl-format plists suitable for passing to `array set' mapping database
 569 ## fields to values.
 570
 571 proc archive-certificates {} {
 572   ## Archive any certificates and certificate requests which need it.
 573
 574   global CERTROOT C
 575
 576   db transaction {
 577
 578     ## Initial setup.
 579     set when [time-db [expr {[now] - 86400*$C(archive-interval)}]]
 580     array unset archcerts
 581     set archfiles {}
 582     set delfiles {}
 583
 584     ## Prepare the archive staging area.
 585     cd $CERTROOT
 586     set archdir "tmp/arch"
 587     file delete -force $archdir
 588     file delete -force "tmp/arch.tgz"
 589     file mkdir $archdir
 590
 591     ## Dig out the certificates.
 592     set anycert false
 593     with-cleanup {
 594       set out [open "$archdir/certificate.dump" w]
 595       cleanup { close $out }
 596       db eval {
 597         SELECT * FROM certificate
 598         WHERE t_expire <= $when;
 599       } R {
 600         set line {}
 601         foreach i $R(*) { lappend line $i $R($i) }
 602         puts $out $line
 603         set anycert true
 604         set archcerts($R(seq)) 1
 605         file link -hard "$archdir/cert.$R(seq)" "cert/by-seq/$R(seq)"
 606         lappend archfiles "cert.$R(seq)"
 607         lappend delfiles "cert/by-seq/$R(seq)"
 608       }
 609     }
 610
 611     ## Prune the OpenSSL request file.
 612     if {$anycert} {
 613       with-cleanup {
 614         set in [open "state/db"]
 615         cleanup { close $in }
 616         set arch [open "$archdir/openssl-certs.txt" "w"]
 617         cleanup { close $arch }
 618         set new [open "state/db.new" "w"]
 619         cleanup { close $new }
 620
 621         while {[gets $in line] >= 0} {
 622           set seq [expr 0x[lindex [split $line "\t"] 3] + 0]
 623           puts [expr {[info exists archcerts($seq)] ? $arch : $new}] $line
 624         }
 625       }
 626       lappend archfiles "openssl-certs.txt" "certificate.dump"
 627     }
 628
 629     ## Delete the certificates that we archived.  Here we rely on SQLite's
 630     ## strong isolation guarantees to ensure that the DELETE query here
 631     ## matches the same records as the SELECT did above.  Also, we rely on
 632     ## SQLite rolling back if anything goes wrong in the rest of the job.
 633     ## This is considerably simpler than fiddling the queries below to look
 634     ## at the expiry dates of matching certificates.
 635     db eval {
 636       DELETE FROM certificate
 637       WHERE t_expire <= $when;
 638     }
 639
 640     ## Find the orphaned requests.  Don't clobber active requests even if
 641     ## they look orphaned: we might just have failed to create certificates
 642     ## for them for some reason.
 643     set anyreq false
 644     with-cleanup {
 645       set out [open "$archdir/request.dump" w]
 646       cleanup { close $out }
 647       db eval {
 648         SELECT r.*
 649         FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
 650         WHERE c.req IS NULL AND r.st != 'active';
 651       } R {
 652         set line {}
 653         foreach i $R(*) { lappend line $i $R($i) }
 654         puts $out $line
 655         set anyreq true
 656         file link -hard "$archdir/req.$R(id)" "req/by-id/$R(id)"
 657         lappend archfiles "req.$R(id)"
 658         lappend delfiles "req/by-id/$R(id)"
 659       }
 660     }
 661     if {$anyreq} { lappend archfiles "request.dump" }
 662
 663     ## Make the archive.
 664     if {!$anycert && !$anyreq} { return }
 665     cd $archdir
 666     eval exec tar cfz "../arch.tgz" $archfiles
 667
 668     ## Delete the requests that we archived.  Again we rely on SQLite's
 669     ## strong isolation to avoid races.
 670     db eval {
 671       DELETE FROM request
 672       WHERE id IN (
 673               SELECT r.id
 674               FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
 675               WHERE c.req IS NULL AND r.st != 'active');
 676     }
 677
 678     ## Tidy everything up.
 679     cd $CERTROOT
 680     set t [time-db [now]]
 681     file rename "tmp/arch.tgz" "archive/$t.tgz"
 682     if {$anycert} { file rename -force "state/db.new" "state/db" }
 683   }
 684   foreach f $delfiles { file delete $f }
 685   file delete -force $archdir
 686   file delete -force "tmp/arch.tgz"
 687 }
 688
 689 ###--------------------------------------------------------------------------
 690 ### Certificate revocation.
 691
 692 ## Enormous table of revocation reasons and how to handle them.
 693 array set REVOKE_REASON {
 694   unspecified {
 695     unspecified
 696     none
 697   }
 698   key-compromise {
 699     keyCompromise
 700     time "%Y%m%d%H%M%SZ"
 701     -crl_compromise
 702   }
 703   ca-compromise {
 704     CACompromise
 705     time "%Y%m%d%H%M%SZ"
 706     -crl_CA_compromise
 707   }
 708   affiliation-changed {
 709     affiliationChanged
 710     none
 711   }
 712   superceded {
 713     superseded
 714     none
 715   }
 716   cessation-of-operation {
 717     cessationOfOperation
 718     none
 719   }
 720   remove-from-crl {
 721     removeFromCrl
 722     none
 723   }
 724   certificate-hold {
 725     certificateHold
 726     enum {
 727       reject holdInstructionReject
 728       none holdInstructionNone
 729       call-issuer holdInstructionCallIssuer
 730     }
 731     -crl_hold
 732   }
 733 }
 734
 735 proc revoke-reason-info {reason infovar} {
 736   ## Write information about the revocation REASON into the array INFOVAR.
 737   ## The keys defined for INFOVAR are as follows.
 738   ##
 739   ##    reason          The provided reason string.
 740   ##    oid             The OID name for the reason.
 741   ##    detail-type     The type of the detail (for converting details).
 742   ##    detail-info     Additional information for detail conversion
 743   ##    detail-arg      The OpenSSL detail argument name.
 744
 745   global REVOKE_REASON
 746   upvar 1 $infovar R
 747
 748   if {![info exists REVOKE_REASON($reason)]} {
 749     error "unknown revocation reason `$reason'"
 750   }
 751
 752   array unset R
 753   set R(reason) $reason
 754   lassign $REVOKE_REASON($reason) \
 755       R(oid) R(detail-type) R(detail-info) R(detail-arg)
 756 }
 757
 758 proc revoke-parse-detail/none {info detail} {
 759   if {[llength $detail] > 0} {
 760     error "no detail permitted"
 761   }
 762   return nil
 763 }
 764
 765 proc revoke-openssl-args/none {info arg detail} {
 766   return {}
 767 }
 768
 769 proc revoke-parse-detail/time {info detail} {
 770   switch [llength $detail] {
 771     0 { set t [now] }
 772     1 { set t [clock scan [lindex $detail 0]] }
 773     default { error "too many time arguments" }
 774   }
 775   return [time-db $t]
 776 }
 777
 778 proc revoke-openssl-args/time {info arg detail} {
 779   return [list $arg [clock format [db-time $detail] \
 780                          -timezone :UTC \
 781                          -format $info]]
 782 }
 783
 784 proc revoke-parse-detail/enum {info detail} {
 785   switch [llength $detail] {
 786     0 { set r [lindex $info 0] }
 787     1 {
 788       array set M $info
 789       set r [lindex $detail 0]
 790       if {![info exists M($r)]} { error "invalid detail value `$r'" }
 791     }
 792     default { error "too many symbolic arguments" }
 793   }
 794   return $r
 795 }
 796
 797 proc revoke-openssl-args/enum {info arg detail} {
 798   array set M $info
 799   return [list $arg $M($detail)]
 800 }
 801
 802 proc revoke-parse-detail {infovar detail} {
 803   ## Parse a revocation detail, as provided in a command-line argument list,
 804   ## and convert it into the database format.
 805
 806   upvar 1 $infovar R
 807   return [revoke-parse-detail/$R(detail-type) $R(detail-info) $detail]
 808 }
 809
 810 proc revoke-openssl-args {infovar detail} {
 811   ## Return OpenSSL arguments for revoking certificates, given a revocation
 812   ## DETAIL.  You need to provide the `-revoke FILE' bit yourself: this only
 813   ## provides the `-crl_reason REASON' and detail arguments.
 814
 815   upvar 1 $infovar R
 816   return [concat \
 817               [list -crl_reason $R(oid)] \
 818               [revoke-openssl-args/$R(detail-type) \
 819                    $R(detail-info) $R(detail-arg) $detail]]
 820 }
 821
 822 proc revoke-requests {infovar detail reqs} {
 823   ## Revoke a bunch of certificate requests, listed by id in REQS.  The
 824   ## INFOVAR is the name of an array set up by `revoke-reason-info'; the
 825   ## DETAIL is the revocation detail in internal format, e.g., as established
 826   ## by `revoke-parse-detail'.
 827   ##
 828   ## This function establishes its own transaction, but you should wrap it in
 829   ## your own one if you found the REQS list as a result of a database query,
 830   ## in order to avoid race conditions.
 831
 832   ## Find some useful things.
 833   global env
 834   upvar 1 $infovar R
 835   set ossl_args [revoke-openssl-args R $detail]
 836   set del {}
 837
 838   ## Wrap a transaction around, so that we can reset the database if
 839   ## something goes wrong with the file fiddling half-way through.
 840   db transaction {
 841
 842     ## Make a copy of the state database.  We'll work on that using some
 843     ## unpleasant configuration hacking.
 844     file copy -force "state/db" "state/db.revoke"
 845     set env(db_suffix) ".revoke"
 846
 847     ## Now work through the requests one by one, revoking each affected
 848     ## certificate.
 849     foreach req $reqs {
 850
 851       ## Check the request state.  If it was previously active, we must
 852       ## remember to delete the link.  Obviously we shouldn't actually delete
 853       ## them yet, because this might fail catastrophically.
 854       lassign [db eval { SELECT st, tag FROM request WHERE id = $req; }] \
 855           reqst tag
 856       if {[string equal $reqst active]} { lappend del "req/active/$tag" }
 857
 858       ## Now try the certificates.
 859       foreach {cert certst} [db eval {
 860         SELECT seq, st FROM certificate
 861         WHERE req = $req AND st != 'expired';
 862       }] {
 863
 864         ## Check the certificate state: again, we might have to delete the
 865         ## active link.
 866         if {[string equal $certst active]} { lappend del "cert/active/$tag" }
 867
 868         ## Update the certificate state.
 869         db eval { UPDATE certificate SET st = 'revoked' WHERE seq = $cert; }
 870
 871         ## Get OpenSSL to update its database.
 872         eval exec openssl ca \
 873             [list -config "etc/openssl.conf"] \
 874             [list -revoke "cert/by-seq/$cert"] \
 875             $ossl_args \
 876             2>@1
 877       }
 878
 879       ## Finally fiddle the request state.
 880       db eval {
 881         UPDATE request
 882         SET st = 'revoked',
 883         revoke_reason = $R(reason),
 884         revoke_detail = $detail
 885         WHERE id = $req;
 886       }
 887     }
 888
 889     ## Astonishingly all of that actually worked.
 890     file rename -force "state/db.revoke" "state/db"
 891   }
 892
 893   ## Delete the active links we made a note of earlier.
 894   foreach f $del { file delete -force $f }
 895 }
 896
 897 ###--------------------------------------------------------------------------
 898 ### Managing certificates.
 899
 900 proc issue-cert {id now} {
 901   ## Issue a certificate for the request with the given ID.  This doesn't
 902   ## bother to find out whethere it's a good idea.
 903
 904   global CERTROOT
 905   db nullvalue nil
 906
 907   with-cleanup {
 908     db transaction {
 909
 910       ## Find a temporary file name for the output certificate.
 911       fresh-temp "$CERTROOT/tmp" tmp {
 912         set f [open $tmp {WRONLY CREAT EXCL}]
 913       }
 914       cleanup { file delete $tmp }
 915       close $f
 916
 917       ## Find stuff out about the request.
 918       lassign [db eval {
 919         SELECT  p.start_skew, p.expire_interval, p.issue_time, p.extensions,
 920                 r.tag, r.cert_dn
 921         FROM    request AS r JOIN
 922                 profile AS p ON r.profile = p.label
 923         WHERE   r.id = $id;
 924       }] start_skew expire_interval issue_time extensions tag cert_dn
 925
 926       ## Sign the certificate.
 927       set starttime [expr {$now - 3600*$start_skew}]
 928       set endtime [expr {$now + 3600*$expire_interval}]
 929       cleanup { catch { eval file delete [glob "$CERTROOT/tmp/*.pem"] } }
 930       exec openssl ca -batch \
 931           -config "$CERTROOT/etc/openssl.conf" \
 932           -outdir "$CERTROOT/tmp" \
 933           -extensions $extensions \
 934           -startdate [time-asn1 $starttime] \
 935           -enddate [time-asn1 $endtime] \
 936           -in "$CERTROOT/req/by-id/$id" -out $tmp \
 937           2>@1
 938
 939       ## Update the request's cert_dn field.  If it's null, this is the first
 940       ## certificate issued for the request, and we should fill the field in;
 941       ## otherwise we should compare the actual DN to the expected one and
 942       ## fail if it's wrong.
 943       set dn [cert-dn $tmp]
 944       if {[string equal $cert_dn nil]} {
 945         db eval { UPDATE request SET cert_dn = $dn WHERE id = $id; }
 946       } elseif {![string equal $cert_dn $dn]} {
 947         error [join {
 948           "DN mismatch: request $id (`$tag') has $cert_dn; "
 949           "new cert has $dn"} ""]
 950       }
 951
 952       ## Stash a new record in the database.
 953       set expire [time-db $endtime]
 954       set next_issue [time-db [next-matching-date $issue_time $now]]
 955       set now_db [time-db $now]
 956       set seq [cert-seq $tmp]
 957       db eval {
 958         UPDATE certificate
 959         SET st = CASE WHEN t_expire >= $now_db THEN 'superceded'
 960         ELSE 'expired'
 961         END
 962         WHERE req = $id AND st = 'active';
 963
 964         INSERT INTO certificate(seq, req, st, t_expire)
 965         VALUES ($seq, $id, 'active', $expire);
 966
 967         UPDATE request SET t_reissue = $next_issue
 968         WHERE id = $id;
 969       }
 970
 971       ## Put the file in the right place.
 972       file link -hard "$CERTROOT/cert/by-seq/$seq" $tmp
 973       exec ln -sf "../by-seq/$seq" "$CERTROOT/cert/active/$tag"
 974     }
 975   }
 976 }
 977
 978 proc expire-certs {now} {
 979   ## Mark certificates as having expired.
 980
 981   global CERTROOT
 982   set now_db [time-db $now]
 983
 984   ## If we're unlucky, some active certificates may have expired while we
 985   ## weren't looking.  We'll demote these soon, but we must clear away the
 986   ## old links.
 987   foreach tag [db eval {
 988     SELECT r.tag
 989     FROM request AS r JOIN certificate as c ON r.id = c.req
 990     WHERE c.st = 'active' AND c.t_expire < $now_db;
 991   }] {
 992     file delete "$CERTROOT/cert/active/$tag"
 993   }
 994
 995   ## Now demote the states of expired certificates.  All certificates expire,
 996   ## including revoked ones.
 997   db eval {
 998     UPDATE certificate
 999     SET st = 'expired'
1000     WHERE st != 'expired' AND t_expire < $now_db;
1001   }
1002 }
1003
1004 ###----- That's all, folks --------------------------------------------------