1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2013, 2014 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 ui)
28 #:export (%gpg-command
32 gnupg-status-good-signature?
33 gnupg-status-missing-key?))
42 ;; The GnuPG 2.x command-line program name.
43 (make-parameter "gpg2"))
45 (define %openpgp-key-server
46 ;; The default key server. Note that keys.gnupg.net appears to be
48 (make-parameter "pgp.mit.edu"))
50 (define (gnupg-verify sig file)
51 "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed."
53 (define (status-line->sexp line)
54 ;; See file `doc/DETAILS' in GnuPG.
57 "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
59 (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
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:]]+) (.*)$"))
67 "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
69 (cond ((regexp-exec sigid-rx line)
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)
79 `(good-signature ,(match:substring match 1) ; key id
80 ,(match:substring match 2)))) ; user name
81 ((regexp-exec validsig-rx line)
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)
91 `(expired-key-signature ,(match:substring match 1) ; fingerprint
92 ,(match:substring match 2)))) ; user name
93 ((regexp-exec errsig-rx line)
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))
103 (string->number ; return code
104 (match:substring match 6))))
107 ((4) 'unknown-algorithm)
110 `(unparsed-line ,line))))
112 (define (parse-status input)
113 (let loop ((line (read-line input))
115 (if (eof-object? line)
117 (loop (read-line input)
118 (cons (status-line->sexp line) result)))))
120 (let* ((pipe (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1"
121 "--verify" sig file))
122 (status (parse-status pipe)))
123 ;; Ignore PIPE's exit status since STATUS above should contain all the
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."
133 (((or 'good-signature 'expired-key-signature) key-id user)
138 (define (gnupg-status-missing-key? status)
139 "If STATUS denotes a missing-key error, then return the key-id of the
143 (('signature-error key-id _ ...)
148 (define (gnupg-receive-keys key-id server)
149 (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id))
151 (define* (gnupg-verify* sig file
152 #:key (key-download 'interactive)
153 (server (%openpgp-key-server)))
154 "Like `gnupg-verify', but try downloading the public key if it's missing.
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)."
158 (let ((status (gnupg-verify sig file)))
159 (or (gnupg-status-good-signature? status)
160 (let ((missing (gnupg-status-missing-key? status)))
161 (define (download-and-try-again)
162 ;; Download the missing key and try again.
164 (gnupg-receive-keys missing server)
165 (gnupg-status-good-signature? (gnupg-verify sig file))))
169 (begin (format #t (_ "~a~a~%")
170 "Would you like to download this key "
171 "and add it to your keyring?")
173 (string-match (locale-yes-regexp) answer)))
179 (download-and-try-again))
182 (download-and-try-again)))))))))
184 ;;; gnupg.scm ends here