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