[jackhill/guix/guix.git] / guix / gnupg.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix gnupg)
  #:use-module (ice-9 popen)
  #: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)
  #: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?))

;;; Commentary:
;;;
;;; GnuPG interface.
;;;
;;; Code:

(define %gpg-command
  ;; The GnuPG 2.x command-line program name.
  (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))

(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 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* (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)
             `(signature-id ,(match:substring match 1) ; sig id
                            ,(match:substring match 2) ; date
                            ,(string->number           ; timestamp
                              (match:substring match 3)))))
          ((regexp-exec goodsig-rx line)
           =>
           (lambda (match)
             `(good-signature ,(match:substring match 1)    ; key id
                              ,(match:substring match 2)))) ; user name
          ((regexp-exec validsig-rx line)
           =>
           (lambda (match)
             `(valid-signature ,(match:substring match 1) ; fingerprint
                               ,(match:substring match 2) ; sig creation date
                               ,(string->number           ; timestamp
                                 (match:substring match 3)))))
          ((regexp-exec expkeysig-rx line)
           =>
           (lambda (match)
             `(expired-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
                               ,(match:substring match 2) ; pubkey algo
                               ,(match:substring match 3) ; hash algo
                               ,(match:substring match 4) ; sig class
                               ,(string->number           ; timestamp
                                 (match:substring match 5))
                               ,(let ((rc
                                       (string->number ; return code
                                        (match:substring match 6))))
                                  (case rc
                                    ((9) 'missing-key)
                                    ((4) 'unknown-algorithm)
                                    (else rc)))
                               ,(maybe-fingerprint ; fingerprint or #f
                                 (match:substring match 7)))))
          (else
           `(unparsed-line ,line))))

  (define (parse-status input)
    (let loop ((line   (read-line input))
               (result '()))
      (if (eof-object? line)
          (reverse result)
          (loop (read-line input)
                (cons (status-line->sexp line) result)))))

  (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.
    (close-pipe pipe)
    status))

(define (gnupg-status-good-signature? status)
  "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
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))
       ((_ key-id user) (cons fingerprint user))
       (_ #f)))
    (_
     #f)))

(define (gnupg-status-missing-key? status)
  "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 _ ... 'missing-key fingerprint)
            (or fingerprint key-id))
           (_ #f)))
       status))

(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

  (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 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)))
    (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
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>
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
0ba91c94 LC	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
0ba91c94 LC	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
d8169d05 LC	62	;; Regexps for status lines. See file `doc/DETAILS' in GnuPG.
	63
	64	(define sigid-rx
	65	(make-regexp
	66	"^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
	67	(define goodsig-rx
	68	(make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
	69	(define validsig-rx
	70	(make-regexp
	71	"^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
	72	(define expkeysig-rx ; good signature, but expired key
	73	(make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
	74	(define errsig-rx
	75	;; Note: The fingeprint part (the last element of the line) appeared in
	76	;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
	77	(make-regexp
	78	"^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
	79
	80
b9e1fddf LC	81	(define* (gnupg-verify sig file
	82	#:optional (keyring (current-keyring)))
	83	"Verify signature SIG for FILE against the keys in KEYRING. All the keys in
	84	KEYRING as assumed to be \"trusted\", whether or not they expired or were
	85	revoked. Return a status s-exp if GnuPG failed."
0fdd3bea	86
217b4a15 LC	87	(define (maybe-fingerprint str)
	88	(match (string-trim-both str)
	89	((or "-" "") #f)
	90	(fpr fpr)))
	91
0fdd3bea	92	(define (status-line->sexp line)
0fdd3bea LC	93	(cond ((regexp-exec sigid-rx line)
	94	=>
	95	(lambda (match)
	96	`(signature-id ,(match:substring match 1) ; sig id
	97	,(match:substring match 2) ; date
	98	,(string->number ; timestamp
	99	(match:substring match 3)))))
	100	((regexp-exec goodsig-rx line)
	101	=>
	102	(lambda (match)
	103	`(good-signature ,(match:substring match 1) ; key id
	104	,(match:substring match 2)))) ; user name
	105	((regexp-exec validsig-rx line)
	106	=>
	107	(lambda (match)
	108	`(valid-signature ,(match:substring match 1) ; fingerprint
	109	,(match:substring match 2) ; sig creation date
	110	,(string->number ; timestamp
	111	(match:substring match 3)))))
	112	((regexp-exec expkeysig-rx line)
	113	=>
	114	(lambda (match)
	115	`(expired-key-signature ,(match:substring match 1) ; fingerprint
	116	,(match:substring match 2)))) ; user name
	117	((regexp-exec errsig-rx line)
	118	=>
	119	(lambda (match)
217b4a15	120	`(signature-error ,(match:substring match 1) ; key id
0fdd3bea LC	121	,(match:substring match 2) ; pubkey algo
	122	,(match:substring match 3) ; hash algo
	123	,(match:substring match 4) ; sig class
	124	,(string->number ; timestamp
	125	(match:substring match 5))
	126	,(let ((rc
	127	(string->number ; return code
	128	(match:substring match 6))))
	129	(case rc
	130	((9) 'missing-key)
	131	((4) 'unknown-algorithm)
217b4a15 LC	132	(else rc)))
	133	,(maybe-fingerprint ; fingerprint or #f
	134	(match:substring match 7)))))
0fdd3bea LC	135	(else
	136	`(unparsed-line ,line))))
	137
	138	(define (parse-status input)
	139	(let loop ((line (read-line input))
	140	(result '()))
	141	(if (eof-object? line)
	142	(reverse result)
	143	(loop (read-line input)
	144	(cons (status-line->sexp line) result)))))
	145
b9e1fddf LC	146	(let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
b9e1fddf LC	147	"--keyring" keyring sig file))
0fdd3bea LC	148	(status (parse-status pipe)))
	149	;; Ignore PIPE's exit status since STATUS above should contain all the
	150	;; info we need.
	151	(close-pipe pipe)
	152	status))
	153
	154	(define (gnupg-status-good-signature? status)
	155	"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
9cfa3225 LC	156	a fingerprint/user pair; return #f otherwise."
	157	(match (assq 'valid-signature status)
	158	(('valid-signature fingerprint date timestamp)
	159	(match (or (assq 'good-signature status)
	160	(assq 'expired-key-signature status))
	161	((_ key-id user) (cons fingerprint user))
	162	(_ #f)))
	163	(_
	164	#f)))
0fdd3bea LC	165
0fdd3bea LC	166	(define (gnupg-status-missing-key? status)
217b4a15 LC	167	"If STATUS denotes a missing-key error, then return the fingerprint of the
217b4a15 LC	168	missing key or its key id if the fingerprint is unavailable."
0fdd3bea LC	169	(any (lambda (sexp)
0fdd3bea LC	170	(match sexp
217b4a15 LC	171	(('signature-error key-id _ ... 'missing-key fingerprint)
217b4a15 LC	172	(or fingerprint key-id))
0fdd3bea LC	173	(_ #f)))
	174	status))
	175
217b4a15	176	(define* (gnupg-receive-keys fingerprint/key-id server
b9e1fddf	177	#:optional (keyring (current-keyring)))
f94f9d67 LC	178	"Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
f94f9d67 LC	179	KEYRING."
b9e1fddf LC	180	(unless (file-exists? keyring)
	181	(mkdir-p (dirname keyring))
	182	(call-with-output-file keyring (const #t))) ;create an empty keybox
	183
f94f9d67 LC	184	(zero? (system* (%gpg-command) "--keyserver" server
	185	"--no-default-keyring" "--keyring" keyring
	186	"--recv-keys" fingerprint/key-id)))
0fdd3bea	187
392b5d8c	188	(define* (gnupg-verify* sig file
b9e1fddf LC	189	#:key
	190	(key-download 'interactive)
	191	(server (%openpgp-key-server))
	192	(keyring (current-keyring)))
0fdd3bea	193	"Like `gnupg-verify', but try downloading the public key if it's missing.
f94f9d67 LC	194	Return two values: 'valid-signature and a fingerprint/name pair upon success,
	195	'missing-key and a fingerprint if the key could not be found, and
	196	'invalid-signature with a fingerprint if the signature is invalid.
	197
	198	KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
	199	values: 'always', 'never', and 'interactive' (default). Return a
	200	fingerprint/user name pair on success and #f otherwise."
0fdd3bea	201	(let ((status (gnupg-verify sig file)))
f94f9d67 LC	202	(match (gnupg-status-good-signature? status)
	203	((fingerprint . user)
	204	(values 'valid-signature (cons fingerprint user)))
	205	(#f
	206	(let ((missing (gnupg-status-missing-key? status)))
	207	(define (download-and-try-again)
	208	;; Download the missing key and try again.
	209	(if (gnupg-receive-keys missing server keyring)
	210	(match (gnupg-status-good-signature?
	211	(gnupg-verify sig file keyring))
	212	(#f
	213	(values 'invalid-signature missing))
	214	((fingerprint . user)
	215	(values 'valid-signature
	216	(cons fingerprint user))))
	217	(values 'missing-key missing)))
	218
	219	(define (receive?)
	220	(let ((answer
	221	(begin
	222	(format #t (G_ "Would you like to add this key \
b9e1fddf	223	to keyring '~a'?~%")
f94f9d67 LC	224	keyring)
	225	(read-line))))
	226	(string-match (locale-yes-regexp) answer)))
	227
	228	(case key-download
	229	((never)
	230	(values 'missing-key missing))
	231	((always)
	232	(download-and-try-again))
	233	(else
	234	(if (receive?)
	235	(download-and-try-again)
	236	(values 'missing-key missing)))))))))
0fdd3bea LC	237
0fdd3bea LC	238	;;; gnupg.scm ends here