Commit | Line | Data |
---|---|---|
0fdd3bea LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org> | |
392b5d8c | 3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
0fdd3bea LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix gnupg) | |
21 | #:use-module (ice-9 popen) | |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (ice-9 regex) | |
24 | #:use-module (ice-9 rdelim) | |
392b5d8c | 25 | #:use-module (ice-9 i18n) |
0fdd3bea | 26 | #:use-module (srfi srfi-1) |
392b5d8c | 27 | #:use-module (guix ui) |
0ba91c94 LC |
28 | #:export (%gpg-command |
29 | %openpgp-key-server | |
30 | gnupg-verify | |
0fdd3bea LC |
31 | gnupg-verify* |
32 | gnupg-status-good-signature? | |
33 | gnupg-status-missing-key?)) | |
34 | ||
35 | ;;; Commentary: | |
36 | ;;; | |
37 | ;;; GnuPG interface. | |
38 | ;;; | |
39 | ;;; Code: | |
40 | ||
0ba91c94 LC |
41 | (define %gpg-command |
42 | ;; The GnuPG 2.x command-line program name. | |
43 | (make-parameter "gpg2")) | |
44 | ||
45 | (define %openpgp-key-server | |
46 | ;; The default key server. Note that keys.gnupg.net appears to be | |
47 | ;; unreliable. | |
48 | (make-parameter "pgp.mit.edu")) | |
0fdd3bea LC |
49 | |
50 | (define (gnupg-verify sig file) | |
51 | "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed." | |
52 | ||
53 | (define (status-line->sexp line) | |
54 | ;; See file `doc/DETAILS' in GnuPG. | |
55 | (define sigid-rx | |
56 | (make-regexp | |
57 | "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) | |
58 | (define goodsig-rx | |
59 | (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) | |
60 | (define validsig-rx | |
61 | (make-regexp | |
62 | "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) | |
63 | (define expkeysig-rx ; good signature, but expired key | |
64 | (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) | |
65 | (define errsig-rx | |
66 | (make-regexp | |
67 | "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)")) | |
68 | ||
69 | (cond ((regexp-exec sigid-rx line) | |
70 | => | |
71 | (lambda (match) | |
72 | `(signature-id ,(match:substring match 1) ; sig id | |
73 | ,(match:substring match 2) ; date | |
74 | ,(string->number ; timestamp | |
75 | (match:substring match 3))))) | |
76 | ((regexp-exec goodsig-rx line) | |
77 | => | |
78 | (lambda (match) | |
79 | `(good-signature ,(match:substring match 1) ; key id | |
80 | ,(match:substring match 2)))) ; user name | |
81 | ((regexp-exec validsig-rx line) | |
82 | => | |
83 | (lambda (match) | |
84 | `(valid-signature ,(match:substring match 1) ; fingerprint | |
85 | ,(match:substring match 2) ; sig creation date | |
86 | ,(string->number ; timestamp | |
87 | (match:substring match 3))))) | |
88 | ((regexp-exec expkeysig-rx line) | |
89 | => | |
90 | (lambda (match) | |
91 | `(expired-key-signature ,(match:substring match 1) ; fingerprint | |
92 | ,(match:substring match 2)))) ; user name | |
93 | ((regexp-exec errsig-rx line) | |
94 | => | |
95 | (lambda (match) | |
96 | `(signature-error ,(match:substring match 1) ; key id or fingerprint | |
97 | ,(match:substring match 2) ; pubkey algo | |
98 | ,(match:substring match 3) ; hash algo | |
99 | ,(match:substring match 4) ; sig class | |
100 | ,(string->number ; timestamp | |
101 | (match:substring match 5)) | |
102 | ,(let ((rc | |
103 | (string->number ; return code | |
104 | (match:substring match 6)))) | |
105 | (case rc | |
106 | ((9) 'missing-key) | |
107 | ((4) 'unknown-algorithm) | |
108 | (else rc)))))) | |
109 | (else | |
110 | `(unparsed-line ,line)))) | |
111 | ||
112 | (define (parse-status input) | |
113 | (let loop ((line (read-line input)) | |
114 | (result '())) | |
115 | (if (eof-object? line) | |
116 | (reverse result) | |
117 | (loop (read-line input) | |
118 | (cons (status-line->sexp line) result))))) | |
119 | ||
0ba91c94 | 120 | (let* ((pipe (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1" |
0fdd3bea LC |
121 | "--verify" sig file)) |
122 | (status (parse-status pipe))) | |
123 | ;; Ignore PIPE's exit status since STATUS above should contain all the | |
124 | ;; info we need. | |
125 | (close-pipe pipe) | |
126 | status)) | |
127 | ||
128 | (define (gnupg-status-good-signature? status) | |
129 | "If STATUS, as returned by `gnupg-verify', denotes a good signature, return | |
130 | a key-id/user pair; return #f otherwise." | |
131 | (any (lambda (sexp) | |
132 | (match sexp | |
133 | (((or 'good-signature 'expired-key-signature) key-id user) | |
134 | (cons key-id user)) | |
135 | (_ #f))) | |
136 | status)) | |
137 | ||
138 | (define (gnupg-status-missing-key? status) | |
139 | "If STATUS denotes a missing-key error, then return the key-id of the | |
140 | missing key." | |
141 | (any (lambda (sexp) | |
142 | (match sexp | |
143 | (('signature-error key-id _ ...) | |
144 | key-id) | |
145 | (_ #f))) | |
146 | status)) | |
147 | ||
148 | (define (gnupg-receive-keys key-id server) | |
0ba91c94 | 149 | (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id)) |
0fdd3bea | 150 | |
392b5d8c NK |
151 | (define* (gnupg-verify* sig file |
152 | #:key (key-download 'interactive) | |
153 | (server (%openpgp-key-server))) | |
0fdd3bea | 154 | "Like `gnupg-verify', but try downloading the public key if it's missing. |
392b5d8c NK |
155 | Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a |
156 | download policy for missing OpenPGP keys; allowed values: 'always', 'never', | |
157 | and 'interactive' (default)." | |
0fdd3bea LC |
158 | (let ((status (gnupg-verify sig file))) |
159 | (or (gnupg-status-good-signature? status) | |
160 | (let ((missing (gnupg-status-missing-key? status))) | |
392b5d8c NK |
161 | (define (download-and-try-again) |
162 | ;; Download the missing key and try again. | |
163 | (begin | |
164 | (gnupg-receive-keys missing server) | |
165 | (gnupg-status-good-signature? (gnupg-verify sig file)))) | |
166 | ||
167 | (define (receive?) | |
168 | (let ((answer | |
169 | (begin (format #t (_ "~a~a~%") | |
170 | "Would you like to download this key " | |
171 | "and add it to your keyring?") | |
172 | (read-line)))) | |
173 | (string-match (locale-yes-regexp) answer))) | |
174 | ||
0fdd3bea | 175 | (and missing |
392b5d8c NK |
176 | (case key-download |
177 | ((never) #f) | |
178 | ((always) | |
179 | (download-and-try-again)) | |
180 | (else | |
181 | (and (receive?) | |
182 | (download-and-try-again))))))))) | |
0fdd3bea LC |
183 | |
184 | ;;; gnupg.scm ends here |