Commit | Line | Data |
---|---|---|
0fdd3bea | 1 | ;;; GNU Guix --- Functional package management for GNU |
9cfa3225 | 2 | ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
392b5d8c | 3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
aa78c596 | 4 | ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
0fdd3bea LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (guix gnupg) | |
22 | #:use-module (ice-9 popen) | |
23 | #:use-module (ice-9 match) | |
24 | #:use-module (ice-9 regex) | |
25 | #:use-module (ice-9 rdelim) | |
392b5d8c | 26 | #:use-module (ice-9 i18n) |
0fdd3bea | 27 | #:use-module (srfi srfi-1) |
b9e1fddf LC |
28 | #:use-module (guix i18n) |
29 | #:use-module ((guix utils) #:select (config-directory)) | |
30 | #:use-module ((guix build utils) #:select (mkdir-p)) | |
0ba91c94 LC |
31 | #:export (%gpg-command |
32 | %openpgp-key-server | |
b9e1fddf | 33 | current-keyring |
0ba91c94 | 34 | gnupg-verify |
0fdd3bea LC |
35 | gnupg-verify* |
36 | gnupg-status-good-signature? | |
37 | gnupg-status-missing-key?)) | |
38 | ||
39 | ;;; Commentary: | |
40 | ;;; | |
41 | ;;; GnuPG interface. | |
42 | ;;; | |
43 | ;;; Code: | |
44 | ||
0ba91c94 LC |
45 | (define %gpg-command |
46 | ;; The GnuPG 2.x command-line program name. | |
0c90ed55 | 47 | (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg"))) |
0ba91c94 | 48 | |
b9e1fddf LC |
49 | (define %gpgv-command |
50 | ;; The 'gpgv' program. | |
51 | (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv"))) | |
52 | ||
53 | (define current-keyring | |
54 | ;; The default keyring of "trusted keys". | |
55 | (make-parameter (string-append (config-directory #:ensure? #f) | |
56 | "/gpg/trustedkeys.kbx"))) | |
57 | ||
0ba91c94 LC |
58 | (define %openpgp-key-server |
59 | ;; The default key server. Note that keys.gnupg.net appears to be | |
60 | ;; unreliable. | |
2e3a6250 | 61 | (make-parameter "pool.sks-keyservers.net")) |
0fdd3bea | 62 | |
d8169d05 LC |
63 | ;; Regexps for status lines. See file `doc/DETAILS' in GnuPG. |
64 | ||
65 | (define sigid-rx | |
66 | (make-regexp | |
67 | "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) | |
68 | (define goodsig-rx | |
69 | (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) | |
70 | (define validsig-rx | |
71 | (make-regexp | |
72 | "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) | |
73 | (define expkeysig-rx ; good signature, but expired key | |
74 | (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) | |
aa78c596 TGR |
75 | (define revkeysig-rx ; good signature, but revoked key |
76 | (make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$")) | |
d8169d05 LC |
77 | (define errsig-rx |
78 | ;; Note: The fingeprint part (the last element of the line) appeared in | |
79 | ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing. | |
80 | (make-regexp | |
81 | "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)")) | |
82 | ||
83 | ||
b9e1fddf LC |
84 | (define* (gnupg-verify sig file |
85 | #:optional (keyring (current-keyring))) | |
86 | "Verify signature SIG for FILE against the keys in KEYRING. All the keys in | |
87 | KEYRING as assumed to be \"trusted\", whether or not they expired or were | |
88 | revoked. Return a status s-exp if GnuPG failed." | |
0fdd3bea | 89 | |
217b4a15 LC |
90 | (define (maybe-fingerprint str) |
91 | (match (string-trim-both str) | |
92 | ((or "-" "") #f) | |
93 | (fpr fpr))) | |
94 | ||
0fdd3bea | 95 | (define (status-line->sexp line) |
0fdd3bea LC |
96 | (cond ((regexp-exec sigid-rx line) |
97 | => | |
98 | (lambda (match) | |
99 | `(signature-id ,(match:substring match 1) ; sig id | |
100 | ,(match:substring match 2) ; date | |
101 | ,(string->number ; timestamp | |
102 | (match:substring match 3))))) | |
103 | ((regexp-exec goodsig-rx line) | |
104 | => | |
105 | (lambda (match) | |
106 | `(good-signature ,(match:substring match 1) ; key id | |
107 | ,(match:substring match 2)))) ; user name | |
108 | ((regexp-exec validsig-rx line) | |
109 | => | |
110 | (lambda (match) | |
111 | `(valid-signature ,(match:substring match 1) ; fingerprint | |
112 | ,(match:substring match 2) ; sig creation date | |
113 | ,(string->number ; timestamp | |
114 | (match:substring match 3))))) | |
115 | ((regexp-exec expkeysig-rx line) | |
116 | => | |
117 | (lambda (match) | |
118 | `(expired-key-signature ,(match:substring match 1) ; fingerprint | |
119 | ,(match:substring match 2)))) ; user name | |
aa78c596 TGR |
120 | ((regexp-exec revkeysig-rx line) |
121 | => | |
122 | (lambda (match) | |
123 | `(revoked-key-signature ,(match:substring match 1) ; fingerprint | |
124 | ,(match:substring match 2)))) ; user name | |
0fdd3bea LC |
125 | ((regexp-exec errsig-rx line) |
126 | => | |
127 | (lambda (match) | |
217b4a15 | 128 | `(signature-error ,(match:substring match 1) ; key id |
0fdd3bea LC |
129 | ,(match:substring match 2) ; pubkey algo |
130 | ,(match:substring match 3) ; hash algo | |
131 | ,(match:substring match 4) ; sig class | |
132 | ,(string->number ; timestamp | |
133 | (match:substring match 5)) | |
134 | ,(let ((rc | |
135 | (string->number ; return code | |
136 | (match:substring match 6)))) | |
137 | (case rc | |
138 | ((9) 'missing-key) | |
139 | ((4) 'unknown-algorithm) | |
217b4a15 LC |
140 | (else rc))) |
141 | ,(maybe-fingerprint ; fingerprint or #f | |
142 | (match:substring match 7))))) | |
0fdd3bea LC |
143 | (else |
144 | `(unparsed-line ,line)))) | |
145 | ||
146 | (define (parse-status input) | |
147 | (let loop ((line (read-line input)) | |
148 | (result '())) | |
149 | (if (eof-object? line) | |
150 | (reverse result) | |
151 | (loop (read-line input) | |
152 | (cons (status-line->sexp line) result))))) | |
153 | ||
b9e1fddf LC |
154 | (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1" |
155 | "--keyring" keyring sig file)) | |
0fdd3bea LC |
156 | (status (parse-status pipe))) |
157 | ;; Ignore PIPE's exit status since STATUS above should contain all the | |
158 | ;; info we need. | |
159 | (close-pipe pipe) | |
160 | status)) | |
161 | ||
162 | (define (gnupg-status-good-signature? status) | |
163 | "If STATUS, as returned by `gnupg-verify', denotes a good signature, return | |
9cfa3225 LC |
164 | a fingerprint/user pair; return #f otherwise." |
165 | (match (assq 'valid-signature status) | |
166 | (('valid-signature fingerprint date timestamp) | |
167 | (match (or (assq 'good-signature status) | |
aa78c596 TGR |
168 | (assq 'expired-key-signature status) |
169 | (assq 'revoked-key-signature status)) | |
9cfa3225 LC |
170 | ((_ key-id user) (cons fingerprint user)) |
171 | (_ #f))) | |
172 | (_ | |
173 | #f))) | |
0fdd3bea LC |
174 | |
175 | (define (gnupg-status-missing-key? status) | |
217b4a15 LC |
176 | "If STATUS denotes a missing-key error, then return the fingerprint of the |
177 | missing key or its key id if the fingerprint is unavailable." | |
0fdd3bea LC |
178 | (any (lambda (sexp) |
179 | (match sexp | |
217b4a15 LC |
180 | (('signature-error key-id _ ... 'missing-key fingerprint) |
181 | (or fingerprint key-id)) | |
0fdd3bea LC |
182 | (_ #f))) |
183 | status)) | |
184 | ||
217b4a15 | 185 | (define* (gnupg-receive-keys fingerprint/key-id server |
b9e1fddf | 186 | #:optional (keyring (current-keyring))) |
f94f9d67 LC |
187 | "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to |
188 | KEYRING." | |
b9e1fddf LC |
189 | (unless (file-exists? keyring) |
190 | (mkdir-p (dirname keyring)) | |
191 | (call-with-output-file keyring (const #t))) ;create an empty keybox | |
192 | ||
f94f9d67 LC |
193 | (zero? (system* (%gpg-command) "--keyserver" server |
194 | "--no-default-keyring" "--keyring" keyring | |
195 | "--recv-keys" fingerprint/key-id))) | |
0fdd3bea | 196 | |
392b5d8c | 197 | (define* (gnupg-verify* sig file |
b9e1fddf LC |
198 | #:key |
199 | (key-download 'interactive) | |
200 | (server (%openpgp-key-server)) | |
201 | (keyring (current-keyring))) | |
0fdd3bea | 202 | "Like `gnupg-verify', but try downloading the public key if it's missing. |
f94f9d67 LC |
203 | Return two values: 'valid-signature and a fingerprint/name pair upon success, |
204 | 'missing-key and a fingerprint if the key could not be found, and | |
205 | 'invalid-signature with a fingerprint if the signature is invalid. | |
206 | ||
207 | KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed | |
208 | values: 'always', 'never', and 'interactive' (default). Return a | |
209 | fingerprint/user name pair on success and #f otherwise." | |
0fdd3bea | 210 | (let ((status (gnupg-verify sig file))) |
f94f9d67 LC |
211 | (match (gnupg-status-good-signature? status) |
212 | ((fingerprint . user) | |
213 | (values 'valid-signature (cons fingerprint user))) | |
214 | (#f | |
215 | (let ((missing (gnupg-status-missing-key? status))) | |
216 | (define (download-and-try-again) | |
217 | ;; Download the missing key and try again. | |
218 | (if (gnupg-receive-keys missing server keyring) | |
219 | (match (gnupg-status-good-signature? | |
220 | (gnupg-verify sig file keyring)) | |
221 | (#f | |
222 | (values 'invalid-signature missing)) | |
223 | ((fingerprint . user) | |
224 | (values 'valid-signature | |
225 | (cons fingerprint user)))) | |
226 | (values 'missing-key missing))) | |
227 | ||
228 | (define (receive?) | |
229 | (let ((answer | |
230 | (begin | |
231 | (format #t (G_ "Would you like to add this key \ | |
b9e1fddf | 232 | to keyring '~a'?~%") |
f94f9d67 LC |
233 | keyring) |
234 | (read-line)))) | |
235 | (string-match (locale-yes-regexp) answer))) | |
236 | ||
237 | (case key-download | |
238 | ((never) | |
239 | (values 'missing-key missing)) | |
240 | ((always) | |
241 | (download-and-try-again)) | |
242 | (else | |
243 | (if (receive?) | |
244 | (download-and-try-again) | |
245 | (values 'missing-key missing))))))))) | |
0fdd3bea LC |
246 | |
247 | ;;; gnupg.scm ends here |