| 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 < $n || $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 = $(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 -------------------------------------------------- |