;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 i18n)
#:use-module (srfi srfi-1)
- #:export (gnupg-verify
+ #:use-module (guix i18n)
+ #:use-module ((guix utils) #:select (config-directory))
+ #:use-module ((guix build utils) #:select (mkdir-p))
+ #:export (%gpg-command
+ %openpgp-key-server
+ current-keyring
+ gnupg-verify
gnupg-verify*
gnupg-status-good-signature?
gnupg-status-missing-key?))
;;;
;;; Code:
-(define %gpg-command "gpg2")
-(define %openpgp-key-server "keys.gnupg.net")
+(define %gpg-command
+ ;; The GnuPG 2.x command-line program name.
+ (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
-(define (gnupg-verify sig file)
- "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed."
+(define %gpgv-command
+ ;; The 'gpgv' program.
+ (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
+
+(define current-keyring
+ ;; The default keyring of "trusted keys".
+ (make-parameter (string-append (config-directory #:ensure? #f)
+ "/gpg/trustedkeys.kbx")))
+
+(define %openpgp-key-server
+ ;; The default key server. Note that keys.gnupg.net appears to be
+ ;; unreliable.
+ (make-parameter "pool.sks-keyservers.net"))
+
+;; Regexps for status lines. See file `doc/DETAILS' in GnuPG.
+
+(define sigid-rx
+ (make-regexp
+ "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
+(define goodsig-rx
+ (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
+(define validsig-rx
+ (make-regexp
+ "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
+(define expkeysig-rx ; good signature, but expired key
+ (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
+(define revkeysig-rx ; good signature, but revoked key
+ (make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$"))
+(define errsig-rx
+ ;; Note: The fingeprint part (the last element of the line) appeared in
+ ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
+ (make-regexp
+ "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
- (define (status-line->sexp line)
- ;; See file `doc/DETAILS' in GnuPG.
- (define sigid-rx
- (make-regexp
- "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
- (define goodsig-rx
- (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
- (define validsig-rx
- (make-regexp
- "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
- (define expkeysig-rx ; good signature, but expired key
- (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
- (define errsig-rx
- (make-regexp
- "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
+(define* (gnupg-verify sig file
+ #:optional (keyring (current-keyring)))
+ "Verify signature SIG for FILE against the keys in KEYRING. All the keys in
+KEYRING as assumed to be \"trusted\", whether or not they expired or were
+revoked. Return a status s-exp if GnuPG failed."
+
+ (define (maybe-fingerprint str)
+ (match (string-trim-both str)
+ ((or "-" "") #f)
+ (fpr fpr)))
+
+ (define (status-line->sexp line)
(cond ((regexp-exec sigid-rx line)
=>
(lambda (match)
(lambda (match)
`(expired-key-signature ,(match:substring match 1) ; fingerprint
,(match:substring match 2)))) ; user name
+ ((regexp-exec revkeysig-rx line)
+ =>
+ (lambda (match)
+ `(revoked-key-signature ,(match:substring match 1) ; fingerprint
+ ,(match:substring match 2)))) ; user name
((regexp-exec errsig-rx line)
=>
(lambda (match)
- `(signature-error ,(match:substring match 1) ; key id or fingerprint
+ `(signature-error ,(match:substring match 1) ; key id
,(match:substring match 2) ; pubkey algo
,(match:substring match 3) ; hash algo
,(match:substring match 4) ; sig class
(case rc
((9) 'missing-key)
((4) 'unknown-algorithm)
- (else rc))))))
+ (else rc)))
+ ,(maybe-fingerprint ; fingerprint or #f
+ (match:substring match 7)))))
(else
`(unparsed-line ,line))))
(loop (read-line input)
(cons (status-line->sexp line) result)))))
- (let* ((pipe (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
- "--verify" sig file))
+ (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
+ "--keyring" keyring sig file))
(status (parse-status pipe)))
;; Ignore PIPE's exit status since STATUS above should contain all the
;; info we need.
(define (gnupg-status-good-signature? status)
"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
-a key-id/user pair; return #f otherwise."
- (any (lambda (sexp)
- (match sexp
- (((or 'good-signature 'expired-key-signature) key-id user)
- (cons key-id user))
- (_ #f)))
- status))
+a fingerprint/user pair; return #f otherwise."
+ (match (assq 'valid-signature status)
+ (('valid-signature fingerprint date timestamp)
+ (match (or (assq 'good-signature status)
+ (assq 'expired-key-signature status)
+ (assq 'revoked-key-signature status))
+ ((_ key-id user) (cons fingerprint user))
+ (_ #f)))
+ (_
+ #f)))
(define (gnupg-status-missing-key? status)
- "If STATUS denotes a missing-key error, then return the key-id of the
-missing key."
+ "If STATUS denotes a missing-key error, then return the fingerprint of the
+missing key or its key id if the fingerprint is unavailable."
(any (lambda (sexp)
(match sexp
- (('signature-error key-id _ ...)
- key-id)
+ (('signature-error key-id _ ... 'missing-key fingerprint)
+ (or fingerprint key-id))
(_ #f)))
status))
-(define (gnupg-receive-keys key-id server)
- (system* %gpg-command "--keyserver" server "--recv-keys" key-id))
+(define* (gnupg-receive-keys fingerprint/key-id server
+ #:optional (keyring (current-keyring)))
+ "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
+KEYRING."
+ (unless (file-exists? keyring)
+ (mkdir-p (dirname keyring))
+ (call-with-output-file keyring (const #t))) ;create an empty keybox
-(define* (gnupg-verify* sig file #:optional (server %openpgp-key-server))
+ (zero? (system* (%gpg-command) "--keyserver" server
+ "--no-default-keyring" "--keyring" keyring
+ "--recv-keys" fingerprint/key-id)))
+
+(define* (gnupg-verify* sig file
+ #:key
+ (key-download 'interactive)
+ (server (%openpgp-key-server))
+ (keyring (current-keyring)))
"Like `gnupg-verify', but try downloading the public key if it's missing.
-Return #t if the signature was good, #f otherwise."
+Return two values: 'valid-signature and a fingerprint/name pair upon success,
+'missing-key and a fingerprint if the key could not be found, and
+'invalid-signature with a fingerprint if the signature is invalid.
+
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default). Return a
+fingerprint/user name pair on success and #f otherwise."
(let ((status (gnupg-verify sig file)))
- (or (gnupg-status-good-signature? status)
- (let ((missing (gnupg-status-missing-key? status)))
- (and missing
- (begin
- ;; Download the missing key and try again.
- (gnupg-receive-keys missing server)
- (gnupg-status-good-signature? (gnupg-verify sig file))))))))
+ (match (gnupg-status-good-signature? status)
+ ((fingerprint . user)
+ (values 'valid-signature (cons fingerprint user)))
+ (#f
+ (let ((missing (gnupg-status-missing-key? status)))
+ (define (download-and-try-again)
+ ;; Download the missing key and try again.
+ (if (gnupg-receive-keys missing server keyring)
+ (match (gnupg-status-good-signature?
+ (gnupg-verify sig file keyring))
+ (#f
+ (values 'invalid-signature missing))
+ ((fingerprint . user)
+ (values 'valid-signature
+ (cons fingerprint user))))
+ (values 'missing-key missing)))
+
+ (define (receive?)
+ (let ((answer
+ (begin
+ (format #t (G_ "Would you like to add this key \
+to keyring '~a'?~%")
+ keyring)
+ (read-line))))
+ (string-match (locale-yes-regexp) answer)))
+
+ (case key-download
+ ((never)
+ (values 'missing-key missing))
+ ((always)
+ (download-and-try-again))
+ (else
+ (if (receive?)
+ (download-and-try-again)
+ (values 'missing-key missing)))))))))
;;; gnupg.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff