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