Commit | Line | Data |
---|---|---|
0fdd3bea | 1 | ;;; GNU Guix --- Functional package management for GNU |
b9e1fddf | 2 | ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 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) |
b9e1fddf LC |
27 | #:use-module (guix i18n) |
28 | #:use-module ((guix utils) #:select (config-directory)) | |
29 | #:use-module ((guix build utils) #:select (mkdir-p)) | |
0ba91c94 LC |
30 | #:export (%gpg-command |
31 | %openpgp-key-server | |
b9e1fddf | 32 | current-keyring |
0ba91c94 | 33 | gnupg-verify |
0fdd3bea LC |
34 | gnupg-verify* |
35 | gnupg-status-good-signature? | |
36 | gnupg-status-missing-key?)) | |
37 | ||
38 | ;;; Commentary: | |
39 | ;;; | |
40 | ;;; GnuPG interface. | |
41 | ;;; | |
42 | ;;; Code: | |
43 | ||
0ba91c94 LC |
44 | (define %gpg-command |
45 | ;; The GnuPG 2.x command-line program name. | |
0c90ed55 | 46 | (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg"))) |
0ba91c94 | 47 | |
b9e1fddf LC |
48 | (define %gpgv-command |
49 | ;; The 'gpgv' program. | |
50 | (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv"))) | |
51 | ||
52 | (define current-keyring | |
53 | ;; The default keyring of "trusted keys". | |
54 | (make-parameter (string-append (config-directory #:ensure? #f) | |
55 | "/gpg/trustedkeys.kbx"))) | |
56 | ||
0ba91c94 LC |
57 | (define %openpgp-key-server |
58 | ;; The default key server. Note that keys.gnupg.net appears to be | |
59 | ;; unreliable. | |
2e3a6250 | 60 | (make-parameter "pool.sks-keyservers.net")) |
0fdd3bea | 61 | |
b9e1fddf LC |
62 | (define* (gnupg-verify sig file |
63 | #:optional (keyring (current-keyring))) | |
64 | "Verify signature SIG for FILE against the keys in KEYRING. All the keys in | |
65 | KEYRING as assumed to be \"trusted\", whether or not they expired or were | |
66 | revoked. Return a status s-exp if GnuPG failed." | |
0fdd3bea LC |
67 | |
68 | (define (status-line->sexp line) | |
69 | ;; See file `doc/DETAILS' in GnuPG. | |
70 | (define sigid-rx | |
71 | (make-regexp | |
27afb11a | 72 | "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) |
0fdd3bea LC |
73 | (define goodsig-rx |
74 | (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) | |
75 | (define validsig-rx | |
76 | (make-regexp | |
77 | "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) | |
78 | (define expkeysig-rx ; good signature, but expired key | |
79 | (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) | |
80 | (define errsig-rx | |
81 | (make-regexp | |
82 | "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)")) | |
83 | ||
84 | (cond ((regexp-exec sigid-rx line) | |
85 | => | |
86 | (lambda (match) | |
87 | `(signature-id ,(match:substring match 1) ; sig id | |
88 | ,(match:substring match 2) ; date | |
89 | ,(string->number ; timestamp | |
90 | (match:substring match 3))))) | |
91 | ((regexp-exec goodsig-rx line) | |
92 | => | |
93 | (lambda (match) | |
94 | `(good-signature ,(match:substring match 1) ; key id | |
95 | ,(match:substring match 2)))) ; user name | |
96 | ((regexp-exec validsig-rx line) | |
97 | => | |
98 | (lambda (match) | |
99 | `(valid-signature ,(match:substring match 1) ; fingerprint | |
100 | ,(match:substring match 2) ; sig creation date | |
101 | ,(string->number ; timestamp | |
102 | (match:substring match 3))))) | |
103 | ((regexp-exec expkeysig-rx line) | |
104 | => | |
105 | (lambda (match) | |
106 | `(expired-key-signature ,(match:substring match 1) ; fingerprint | |
107 | ,(match:substring match 2)))) ; user name | |
108 | ((regexp-exec errsig-rx line) | |
109 | => | |
110 | (lambda (match) | |
111 | `(signature-error ,(match:substring match 1) ; key id or fingerprint | |
112 | ,(match:substring match 2) ; pubkey algo | |
113 | ,(match:substring match 3) ; hash algo | |
114 | ,(match:substring match 4) ; sig class | |
115 | ,(string->number ; timestamp | |
116 | (match:substring match 5)) | |
117 | ,(let ((rc | |
118 | (string->number ; return code | |
119 | (match:substring match 6)))) | |
120 | (case rc | |
121 | ((9) 'missing-key) | |
122 | ((4) 'unknown-algorithm) | |
123 | (else rc)))))) | |
124 | (else | |
125 | `(unparsed-line ,line)))) | |
126 | ||
127 | (define (parse-status input) | |
128 | (let loop ((line (read-line input)) | |
129 | (result '())) | |
130 | (if (eof-object? line) | |
131 | (reverse result) | |
132 | (loop (read-line input) | |
133 | (cons (status-line->sexp line) result))))) | |
134 | ||
b9e1fddf LC |
135 | (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1" |
136 | "--keyring" keyring sig file)) | |
0fdd3bea LC |
137 | (status (parse-status pipe))) |
138 | ;; Ignore PIPE's exit status since STATUS above should contain all the | |
139 | ;; info we need. | |
140 | (close-pipe pipe) | |
141 | status)) | |
142 | ||
143 | (define (gnupg-status-good-signature? status) | |
144 | "If STATUS, as returned by `gnupg-verify', denotes a good signature, return | |
145 | a key-id/user pair; return #f otherwise." | |
146 | (any (lambda (sexp) | |
147 | (match sexp | |
148 | (((or 'good-signature 'expired-key-signature) key-id user) | |
149 | (cons key-id user)) | |
150 | (_ #f))) | |
151 | status)) | |
152 | ||
153 | (define (gnupg-status-missing-key? status) | |
154 | "If STATUS denotes a missing-key error, then return the key-id of the | |
155 | missing key." | |
156 | (any (lambda (sexp) | |
157 | (match sexp | |
158 | (('signature-error key-id _ ...) | |
159 | key-id) | |
160 | (_ #f))) | |
161 | status)) | |
162 | ||
b9e1fddf LC |
163 | (define* (gnupg-receive-keys key-id server |
164 | #:optional (keyring (current-keyring))) | |
165 | (unless (file-exists? keyring) | |
166 | (mkdir-p (dirname keyring)) | |
167 | (call-with-output-file keyring (const #t))) ;create an empty keybox | |
168 | ||
169 | (system* (%gpg-command) "--keyserver" server | |
170 | "--no-default-keyring" "--keyring" keyring | |
171 | "--recv-keys" key-id)) | |
0fdd3bea | 172 | |
392b5d8c | 173 | (define* (gnupg-verify* sig file |
b9e1fddf LC |
174 | #:key |
175 | (key-download 'interactive) | |
176 | (server (%openpgp-key-server)) | |
177 | (keyring (current-keyring))) | |
0fdd3bea | 178 | "Like `gnupg-verify', but try downloading the public key if it's missing. |
392b5d8c NK |
179 | Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a |
180 | download policy for missing OpenPGP keys; allowed values: 'always', 'never', | |
181 | and 'interactive' (default)." | |
0fdd3bea LC |
182 | (let ((status (gnupg-verify sig file))) |
183 | (or (gnupg-status-good-signature? status) | |
184 | (let ((missing (gnupg-status-missing-key? status))) | |
392b5d8c NK |
185 | (define (download-and-try-again) |
186 | ;; Download the missing key and try again. | |
187 | (begin | |
b9e1fddf LC |
188 | (gnupg-receive-keys missing server keyring) |
189 | (gnupg-status-good-signature? (gnupg-verify sig file | |
190 | keyring)))) | |
392b5d8c NK |
191 | |
192 | (define (receive?) | |
193 | (let ((answer | |
b9e1fddf LC |
194 | (begin |
195 | (format #t (G_ "Would you like to add this key \ | |
196 | to keyring '~a'?~%") | |
197 | keyring) | |
198 | (read-line)))) | |
392b5d8c NK |
199 | (string-match (locale-yes-regexp) answer))) |
200 | ||
0fdd3bea | 201 | (and missing |
392b5d8c NK |
202 | (case key-download |
203 | ((never) #f) | |
204 | ((always) | |
205 | (download-and-try-again)) | |
206 | (else | |
207 | (and (receive?) | |
208 | (download-and-try-again))))))))) | |
0fdd3bea LC |
209 | |
210 | ;;; gnupg.scm ends here |