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