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 ### Certificate requests.
 500
 501 proc request-match {reqid cond} {
 502   ## Return a list of request-ids which match REQID and satisfy COND.  The
 503   ## REQID may be a numerical id, a SQL `LIKE' pattern matched against
 504   ## request tags, or the special token `-all'.  The COND is a SQL boolean
 505   ## expression.  The expression is /ignored/ if the REQID is an explicit
 506   ## request id.
 507
 508   set conds {}
 509   set win false
 510
 511   ## Set up the `conds' list to a bunch of SQL expressions we'll try.
 512   if {[string equal $reqid "-all"]} {
 513     set conds [list $cond]
 514     set win true
 515   } else {
 516     if {[string is digit $reqid]} { lappend conds "id = :reqid" }
 517     lappend conds "tag LIKE :reqid AND $cond"
 518   }
 519
 520   ## See if any of the expressions match.
 521   foreach c $conds {
 522     set reqs [db eval "SELECT id FROM request WHERE $c;"]
 523     if {[llength $reqs] > 0} { set win true; break }
 524   }
 525   if {!$win} {
 526     error "no requests match `$reqid'"
 527   }
 528
 529   ## Done.
 530   return $reqs
 531 }
 532
 533 ###--------------------------------------------------------------------------
 534 ### Archival.
 535
 536 ## Archive format.
 537 ##
 538 ## The archive consists of the following files.
 539 ##
 540 ## cert.SEQ             certificate storage
 541 ## req.ID               request storage
 542 ## openssl-certs.txt    OpenSSL records for the certificates
 543 ## certificate.dump     certificate records from the database
 544 ## request.dump         request records from the database
 545 ##
 546 ## The `openssl-certs.txt' file contains lines from the `state.db' file
 547 ## referring to the archived certificates.  The `.dump' files contain
 548 ## Tcl-format plists suitable for passing to `array set' mapping database
 549 ## fields to values.
 550
 551 proc archive-certificates {} {
 552   ## Archive any certificates and certificate requests which need it.
 553
 554   global CERTROOT C
 555
 556   db transaction {
 557
 558     ## Initial setup.
 559     set when [time-db [expr {[now] - 86400*$C(archive-interval)}]]
 560     array unset archcerts
 561     set archfiles {}
 562     set delfiles {}
 563
 564     ## Prepare the archive staging area.
 565     cd $CERTROOT
 566     set archdir "tmp/arch"
 567     file delete -force $archdir
 568     file delete -force "tmp/arch.tgz"
 569     file mkdir $archdir
 570
 571     ## Dig out the certificates.
 572     set anycert false
 573     with-cleanup {
 574       set out [open "$archdir/certificate.dump" w]
 575       cleanup { close $out }
 576       db eval {
 577         SELECT * FROM certificate
 578         WHERE t_expire <= $when;
 579       } R {
 580         set line {}
 581         foreach i $R(*) { lappend line $i $R($i) }
 582         puts $out $line
 583         set anycert true
 584         set archcerts($R(seq)) 1
 585         file link -hard "$archdir/cert.$R(seq)" "cert/by-seq/$R(seq)"
 586         lappend archfiles "cert.$R(seq)"
 587         lappend delfiles "cert/by-seq/$R(seq)"
 588       }
 589     }
 590
 591     ## Prune the OpenSSL request file.
 592     if {$anycert} {
 593       with-cleanup {
 594         set in [open "state/db"]
 595         cleanup { close $in }
 596         set arch [open "$archdir/openssl-certs.txt" "w"]
 597         cleanup { close $arch }
 598         set new [open "state/db.new" "w"]
 599         cleanup { close $new }
 600
 601         while {[gets $in line] >= 0} {
 602           set seq [expr 0x[lindex [split $line "\t"] 3] + 0]
 603           puts [expr {[info exists archcerts($seq)] ? $arch : $new}] $line
 604         }
 605       }
 606       lappend archfiles "openssl-certs.txt" "certificate.dump"
 607     }
 608
 609     ## Delete the certificates that we archived.  Here we rely on SQLite's
 610     ## strong isolation guarantees to ensure that the DELETE query here
 611     ## matches the same records as the SELECT did above.  Also, we rely on
 612     ## SQLite rolling back if anything goes wrong in the rest of the job.
 613     ## This is considerably simpler than fiddling the queries below to look
 614     ## at the expiry dates of matching certificates.
 615     db eval {
 616       DELETE FROM certificate
 617       WHERE t_expire <= $when;
 618     }
 619
 620     ## Find the orphaned requests.  Don't clobber active requests even if
 621     ## they look orphaned: we might just have failed to create certificates
 622     ## for them for some reason.
 623     set anyreq false
 624     with-cleanup {
 625       set out [open "$archdir/request.dump" w]
 626       cleanup { close $out }
 627       db eval {
 628         SELECT r.*
 629         FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
 630         WHERE c.req IS NULL AND r.st != 'active';
 631       } R {
 632         set line {}
 633         foreach i $R(*) { lappend line $i $R($i) }
 634         puts $out $line
 635         set anyreq true
 636         file link -hard "$archdir/req.$R(id)" "req/by-id/$R(id)"
 637         lappend archfiles "req.$R(id)"
 638         lappend delfiles "req/by-id/$R(id)"
 639       }
 640     }
 641     if {$anyreq} { lappend archfiles "request.dump" }
 642
 643     ## Make the archive.
 644     if {!$anycert && !$anyreq} { return }
 645     cd $archdir
 646     eval exec tar cfz "../arch.tgz" $archfiles
 647
 648     ## Delete the requests that we archived.  Again we rely on SQLite's
 649     ## strong isolation to avoid races.
 650     db eval {
 651       DELETE FROM request
 652       WHERE id IN (
 653               SELECT r.id
 654               FROM request AS r LEFT JOIN certificate AS c ON r.id = c.req
 655               WHERE c.req IS NULL AND r.st != 'active');
 656     }
 657
 658     ## Tidy everything up.
 659     cd $CERTROOT
 660     set t [time-db [now]]
 661     file rename "tmp/arch.tgz" "archive/$t.tgz"
 662     if {$anycert} { file rename -force "state/db.new" "state/db" }
 663   }
 664   foreach f $delfiles { file delete $f }
 665   file delete -force $archdir
 666   file delete -force "tmp/arch.tgz"
 667 }
 668
 669 ###--------------------------------------------------------------------------
 670 ### Certificate revocation.
 671
 672 ## Enormous table of revocation reasons and how to handle them.
 673 array set REVOKE_REASON {
 674   unspecified {
 675     unspecified
 676     none
 677   }
 678   key-compromise {
 679     keyCompromise
 680     time "%Y%m%d%H%M%SZ"
 681     -crl_compromise
 682   }
 683   ca-compromise {
 684     CACompromise
 685     time "%Y%m%d%H%M%SZ"
 686     -crl_CA_compromise
 687   }
 688   affiliation-changed {
 689     affiliationChanged
 690     none
 691   }
 692   superceded {
 693     superseded
 694     none
 695   }
 696   cessation-of-operation {
 697     cessationOfOperation
 698     none
 699   }
 700   remove-from-crl {
 701     removeFromCrl
 702     none
 703   }
 704   certificate-hold {
 705     certificateHold
 706     enum {
 707       reject holdInstructionReject
 708       none holdInstructionNone
 709       call-issuer holdInstructionCallIssuer
 710     }
 711     -crl_hold
 712   }
 713 }
 714
 715 proc revoke-reason-info {reason infovar} {
 716   ## Write information about the revocation REASON into the array INFOVAR.
 717   ## The keys defined for INFOVAR are as follows.
 718   ##
 719   ##    reason          The provided reason string.
 720   ##    oid             The OID name for the reason.
 721   ##    detail-type     The type of the detail (for converting details).
 722   ##    detail-info     Additional information for detail conversion
 723   ##    detail-arg      The OpenSSL detail argument name.
 724
 725   global REVOKE_REASON
 726   upvar 1 $infovar R
 727
 728   if {![info exists REVOKE_REASON($reason)]} {
 729     error "unknown revocation reason `$reason'"
 730   }
 731
 732   array unset R
 733   set R(reason) $reason
 734   lassign $REVOKE_REASON($reason) \
 735       R(oid) R(detail-type) R(detail-info) R(detail-arg)
 736 }
 737
 738 proc revoke-parse-detail/none {info detail} {
 739   if {[llength $detail] > 0} {
 740     error "no detail permitted"
 741   }
 742   return nil
 743 }
 744
 745 proc revoke-openssl-args/none {info arg detail} {
 746   return {}
 747 }
 748
 749 proc revoke-parse-detail/time {info detail} {
 750   switch [llength $detail] {
 751     0 { set t [now] }
 752     1 { set t [clock scan [lindex $detail 0]] }
 753     default { error "too many time arguments" }
 754   }
 755   return [time-db $t]
 756 }
 757
 758 proc revoke-openssl-args/time {info arg detail} {
 759   return [list $arg [clock format [db-time $detail] \
 760                          -timezone :UTC \
 761                          -format $info]]
 762 }
 763
 764 proc revoke-parse-detail/enum {info detail} {
 765   switch [llength $detail] {
 766     0 { set r [lindex $info 0] }
 767     1 {
 768       array set M $info
 769       set r [lindex $detail 0]
 770       if {![info exists M($r)]} { error "invalid detail value `$r'" }
 771     }
 772     default { error "too many symbolic arguments" }
 773   }
 774   return $r
 775 }
 776
 777 proc revoke-openssl-args/enum {info arg detail} {
 778   array set M $info
 779   return [list $arg $M($detail)]
 780 }
 781
 782 proc revoke-parse-detail {infovar detail} {
 783   ## Parse a revocation detail, as provided in a command-line argument list,
 784   ## and convert it into the database format.
 785
 786   upvar 1 $infovar R
 787   return [revoke-parse-detail/$R(detail-type) $R(detail-info) $detail]
 788 }
 789
 790 proc revoke-openssl-args {infovar detail} {
 791   ## Return OpenSSL arguments for revoking certificates, given a revocation
 792   ## DETAIL.  You need to provide the `-revoke FILE' bit yourself: this only
 793   ## provides the `-crl_reason REASON' and detail arguments.
 794
 795   upvar 1 $infovar R
 796   return [concat \
 797               [list -crl_reason $R(oid)] \
 798               [revoke-openssl-args/$R(detail-type) \
 799                    $R(detail-info) $R(detail-arg) $detail]]
 800 }
 801
 802 proc revoke-requests {infovar detail reqs} {
 803   ## Revoke a bunch of certificate requests, listed by id in REQS.  The
 804   ## INFOVAR is the name of an array set up by `revoke-reason-info'; the
 805   ## DETAIL is the revocation detail in internal format, e.g., as established
 806   ## by `revoke-parse-detail'.
 807   ##
 808   ## This function establishes its own transaction, but you should wrap it in
 809   ## your own one if you found the REQS list as a result of a database query,
 810   ## in order to avoid race conditions.
 811
 812   ## Find some useful things.
 813   global env
 814   upvar 1 $infovar R
 815   set ossl_args [revoke-openssl-args R $detail]
 816   set del {}
 817
 818   ## Wrap a transaction around, so that we can reset the database if
 819   ## something goes wrong with the file fiddling half-way through.
 820   db transaction {
 821
 822     ## Make a copy of the state database.  We'll work on that using some
 823     ## unpleasant configuration hacking.
 824     file copy -force "state/db" "state/db.revoke"
 825     set env(db_suffix) ".revoke"
 826
 827     ## Now work through the requests one by one, revoking each affected
 828     ## certificate.
 829     foreach req $reqs {
 830
 831       ## Check the request state.  If it was previously active, we must
 832       ## remember to delete the link.  Obviously we shouldn't actually delete
 833       ## them yet, because this might fail catastrophically.
 834       lassign [db eval { SELECT st, tag FROM request WHERE id = $req; }] \
 835           reqst tag
 836       if {[string equal $reqst active]} { lappend del "req/active/$tag" }
 837
 838       ## Now try the certificates.
 839       foreach {cert certst} [db eval {
 840         SELECT seq, st FROM certificate
 841         WHERE req = $req AND st != 'expired';
 842       }] {
 843
 844         ## Check the certificate state: again, we might have to delete the
 845         ## active link.
 846         if {[string equal $certst active]} { lappend del "cert/active/$tag" }
 847
 848         ## Update the certificate state.
 849         db eval { UPDATE certificate SET st = 'revoked' WHERE seq = $cert; }
 850
 851         ## Get OpenSSL to update its database.
 852         eval exec openssl ca \
 853             [list -config "etc/openssl.conf"] \
 854             [list -revoke "cert/by-seq/$cert"] \
 855             $ossl_args \
 856             2>@1
 857       }
 858
 859       ## Finally fiddle the request state.
 860       db eval {
 861         UPDATE request
 862         SET st = 'revoked',
 863         revoke_reason = $R(reason),
 864         revoke_detail = $detail
 865         WHERE id = $req;
 866       }
 867     }
 868
 869     ## Astonishingly all of that actually worked.
 870     file rename -force "state/db.revoke" "state/db"
 871   }
 872
 873   ## Delete the active links we made a note of earlier.
 874   foreach f $del { file delete -force $f }
 875 }
 876
 877 ###--------------------------------------------------------------------------
 878 ### Managing certificates.
 879
 880 proc issue-cert {id now} {
 881   ## Issue a certificate for the request with the given ID.  This doesn't
 882   ## bother to find out whethere it's a good idea.
 883
 884   global CERTROOT
 885   db nullvalue nil
 886
 887   with-cleanup {
 888     db transaction {
 889
 890       ## Find a temporary file name for the output certificate.
 891       fresh-temp "$CERTROOT/tmp" tmp {
 892         set f [open $tmp {WRONLY CREAT EXCL}]
 893       }
 894       cleanup { file delete $tmp }
 895       close $f
 896
 897       ## Find stuff out about the request.
 898       lassign [db eval {
 899         SELECT  p.start_skew, p.expire_interval, p.issue_time, p.extensions,
 900                 r.tag, r.cert_dn
 901         FROM    request AS r JOIN
 902                 profile AS p ON r.profile = p.label
 903         WHERE   r.id = $id;
 904       }] start_skew expire_interval issue_time extensions tag cert_dn
 905
 906       ## Sign the certificate.
 907       set starttime [expr {$now - 3600*$start_skew}]
 908       set endtime [expr {$now + 3600*$expire_interval}]
 909       cleanup { catch { eval file delete [glob "$CERTROOT/tmp/*.pem"] } }
 910       exec openssl ca -batch \
 911           -config "$CERTROOT/etc/openssl.conf" \
 912           -outdir "$CERTROOT/tmp" \
 913           -extensions $extensions \
 914           -startdate [time-asn1 $starttime] \
 915           -enddate [time-asn1 $endtime] \
 916           -in "$CERTROOT/req/by-id/$id" -out $tmp \
 917           2>@1
 918
 919       ## Update the request's cert_dn field.  If it's null, this is the first
 920       ## certificate issued for the request, and we should fill the field in;
 921       ## otherwise we should compare the actual DN to the expected one and
 922       ## fail if it's wrong.
 923       set dn [cert-dn $tmp]
 924       if {[string equal $cert_dn nil]} {
 925         db eval { UPDATE request SET cert_dn = $dn WHERE id = $id; }
 926       } elseif {![string equal $cert_dn $dn]} {
 927         error [join {
 928           "DN mismatch: request $id (`$tag') has $cert_dn; "
 929           "new cert has $dn"} ""]
 930       }
 931
 932       ## Stash a new record in the database.
 933       set expire [time-db $endtime]
 934       set next_issue [time-db [next-matching-date $issue_time $now]]
 935       set now_db [time-db $now]
 936       set seq [cert-seq $tmp]
 937       db eval {
 938         UPDATE certificate
 939         SET st = CASE WHEN t_expire >= $now_db THEN 'superceded'
 940         ELSE 'expired'
 941         END
 942         WHERE req = $id AND st = 'active';
 943
 944         INSERT INTO certificate(seq, req, st, t_expire)
 945         VALUES ($seq, $id, 'active', $expire);
 946
 947         UPDATE request SET t_reissue = $next_issue
 948         WHERE id = $id;
 949       }
 950
 951       ## Put the file in the right place.
 952       file link -hard "$CERTROOT/cert/by-seq/$seq" $tmp
 953       exec ln -sf "../by-seq/$seq" "$CERTROOT/cert/active/$tag"
 954     }
 955   }
 956 }
 957
 958 proc expire-certs {now} {
 959   ## Mark certificates as having expired.
 960
 961   global CERTROOT
 962   set now_db [time-db $now]
 963
 964   ## If we're unlucky, some active certificates may have expired while we
 965   ## weren't looking.  We'll demote these soon, but we must clear away the
 966   ## old links.
 967   foreach tag [db eval {
 968     SELECT r.tag
 969     FROM request AS r JOIN certificate as c ON r.id = c.req
 970     WHERE c.st = 'active' AND c.t_expire < $now_db;
 971   }] {
 972     file delete "$CERTROOT/cert/active/$tag"
 973   }
 974
 975   ## Now demote the states of expired certificates.  All certificates expire,
 976   ## including revoked ones.
 977   db eval {
 978     UPDATE certificate
 979     SET st = 'expired'
 980     WHERE st != 'expired' AND t_expire < $now_db;
 981   }
 982 }
 983
 984 ###----- That's all, folks --------------------------------------------------