1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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)
25 #:use-module (ice-9 i18n)
26 #:use-module (srfi srfi-1)
27 #:use-module (guix i18n)
28 #:use-module ((guix utils) #:select (config-directory))
29 #:use-module ((guix build utils) #:select (mkdir-p))
30 #:export (%gpg-command
35 gnupg-status-good-signature?
36 gnupg-status-missing-key?))
45 ;; The GnuPG 2.x command-line program name.
46 (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
49 ;; The 'gpgv' program.
50 (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
52 (define current-keyring
53 ;; The default keyring of "trusted keys".
54 (make-parameter (string-append (config-directory #:ensure? #f)
55 "/gpg/trustedkeys.kbx")))
57 (define %openpgp-key-server
58 ;; The default key server. Note that keys.gnupg.net appears to be
60 (make-parameter "pool.sks-keyservers.net"))
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."
68 (define (maybe-fingerprint str)
69 (match (string-trim-both str)
73 (define (status-line->sexp line)
74 ;; See file `doc/DETAILS' in GnuPG.
77 "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
79 (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
82 "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
83 (define expkeysig-rx ; good signature, but expired key
84 (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
86 ;; Note: The fingeprint part (the last element of the line) appeared in
87 ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
89 "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
91 (cond ((regexp-exec sigid-rx line)
94 `(signature-id ,(match:substring match 1) ; sig id
95 ,(match:substring match 2) ; date
96 ,(string->number ; timestamp
97 (match:substring match 3)))))
98 ((regexp-exec goodsig-rx line)
101 `(good-signature ,(match:substring match 1) ; key id
102 ,(match:substring match 2)))) ; user name
103 ((regexp-exec validsig-rx line)
106 `(valid-signature ,(match:substring match 1) ; fingerprint
107 ,(match:substring match 2) ; sig creation date
108 ,(string->number ; timestamp
109 (match:substring match 3)))))
110 ((regexp-exec expkeysig-rx line)
113 `(expired-key-signature ,(match:substring match 1) ; fingerprint
114 ,(match:substring match 2)))) ; user name
115 ((regexp-exec errsig-rx line)
118 `(signature-error ,(match:substring match 1) ; key id
119 ,(match:substring match 2) ; pubkey algo
120 ,(match:substring match 3) ; hash algo
121 ,(match:substring match 4) ; sig class
122 ,(string->number ; timestamp
123 (match:substring match 5))
125 (string->number ; return code
126 (match:substring match 6))))
129 ((4) 'unknown-algorithm)
131 ,(maybe-fingerprint ; fingerprint or #f
132 (match:substring match 7)))))
134 `(unparsed-line ,line))))
136 (define (parse-status input)
137 (let loop ((line (read-line input))
139 (if (eof-object? line)
141 (loop (read-line input)
142 (cons (status-line->sexp line) result)))))
144 (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
145 "--keyring" keyring sig file))
146 (status (parse-status pipe)))
147 ;; Ignore PIPE's exit status since STATUS above should contain all the
152 (define (gnupg-status-good-signature? status)
153 "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
154 a fingerprint/user pair; return #f otherwise."
155 (match (assq 'valid-signature status)
156 (('valid-signature fingerprint date timestamp)
157 (match (or (assq 'good-signature status)
158 (assq 'expired-key-signature status))
159 ((_ key-id user) (cons fingerprint user))
164 (define (gnupg-status-missing-key? status)
165 "If STATUS denotes a missing-key error, then return the fingerprint of the
166 missing key or its key id if the fingerprint is unavailable."
169 (('signature-error key-id _ ... 'missing-key fingerprint)
170 (or fingerprint key-id))
174 (define* (gnupg-receive-keys fingerprint/key-id server
175 #:optional (keyring (current-keyring)))
176 (unless (file-exists? keyring)
177 (mkdir-p (dirname keyring))
178 (call-with-output-file keyring (const #t))) ;create an empty keybox
180 (system* (%gpg-command) "--keyserver" server
181 "--no-default-keyring" "--keyring" keyring
182 "--recv-keys" fingerprint/key-id))
184 (define* (gnupg-verify* sig file
186 (key-download 'interactive)
187 (server (%openpgp-key-server))
188 (keyring (current-keyring)))
189 "Like `gnupg-verify', but try downloading the public key if it's missing.
190 Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
191 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
192 and 'interactive' (default). Return a fingerprint/user name pair on success
194 (let ((status (gnupg-verify sig file)))
195 (or (gnupg-status-good-signature? status)
196 (let ((missing (gnupg-status-missing-key? status)))
197 (define (download-and-try-again)
198 ;; Download the missing key and try again.
200 (gnupg-receive-keys missing server keyring)
201 (gnupg-status-good-signature? (gnupg-verify sig file
207 (format #t (G_ "Would you like to add this key \
211 (string-match (locale-yes-regexp) answer)))
217 (download-and-try-again))
220 (download-and-try-again)))))))))
222 ;;; gnupg.scm ends here