[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>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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.  It defaults to #f, which causes GnuPG to use the
  ;; one it is configured with.
  (make-parameter #f))

;; 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* (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 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
                               ,(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)
                (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 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
                             #:key server (keyring (current-keyring)))
  "Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from
GnuPG's default/configured one.  The key is added to KEYRING."
  (unless (file-exists? keyring)
    (mkdir-p (dirname keyring))
    (call-with-output-file keyring (const #t))) ;create an empty keybox

  (zero? (apply system*
                `(,(%gpg-command)
                  ,@(if server
                        (list "--keyserver" server)
                        '())
                  "--no-default-keyring" "--keyring" ,keyring
                  "--recv-keys" ,fingerprint/key-id))))

(define* (gnupg-verify* sig file
                        #:key
                        (key-download 'interactive)
                        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 server #:keyring 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>
aa78c596	4	;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
4c91332c	5	;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
0fdd3bea LC	6	;;;
	7	;;; This file is part of GNU Guix.
	8	;;;
	9	;;; GNU Guix is free software; you can redistribute it and/or modify it
	10	;;; under the terms of the GNU General Public License as published by
	11	;;; the Free Software Foundation; either version 3 of the License, or (at
	12	;;; your option) any later version.
	13	;;;
	14	;;; GNU Guix is distributed in the hope that it will be useful, but
	15	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	16	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	;;; GNU General Public License for more details.
	18	;;;
	19	;;; You should have received a copy of the GNU General Public License
	20	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	21
	22	(define-module (guix gnupg)
	23	#:use-module (ice-9 popen)
	24	#:use-module (ice-9 match)
	25	#:use-module (ice-9 regex)
	26	#:use-module (ice-9 rdelim)
392b5d8c	27	#:use-module (ice-9 i18n)
0fdd3bea	28	#:use-module (srfi srfi-1)
b9e1fddf LC	29	#:use-module (guix i18n)
	30	#:use-module ((guix utils) #:select (config-directory))
	31	#:use-module ((guix build utils) #:select (mkdir-p))
0ba91c94 LC	32	#:export (%gpg-command
0ba91c94 LC	33	%openpgp-key-server
b9e1fddf	34	current-keyring
0ba91c94	35	gnupg-verify
0fdd3bea LC	36	gnupg-verify*
	37	gnupg-status-good-signature?
	38	gnupg-status-missing-key?))
	39
	40	;;; Commentary:
	41	;;;
	42	;;; GnuPG interface.
	43	;;;
	44	;;; Code:
	45
0ba91c94 LC	46	(define %gpg-command
0ba91c94 LC	47	;; The GnuPG 2.x command-line program name.
0c90ed55	48	(make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
0ba91c94	49
b9e1fddf LC	50	(define %gpgv-command
	51	;; The 'gpgv' program.
	52	(make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
	53
	54	(define current-keyring
	55	;; The default keyring of "trusted keys".
	56	(make-parameter (string-append (config-directory #:ensure? #f)
	57	"/gpg/trustedkeys.kbx")))
	58
0ba91c94	59	(define %openpgp-key-server
4c91332c MC	60	;; The default key server. It defaults to #f, which causes GnuPG to use the
	61	;; one it is configured with.
	62	(make-parameter #f))
0fdd3bea	63
d8169d05 LC	64	;; Regexps for status lines. See file `doc/DETAILS' in GnuPG.
	65
	66	(define sigid-rx
	67	(make-regexp
	68	"^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
	69	(define goodsig-rx
	70	(make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
	71	(define validsig-rx
	72	(make-regexp
	73	"^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
	74	(define expkeysig-rx ; good signature, but expired key
	75	(make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
aa78c596 TGR	76	(define revkeysig-rx ; good signature, but revoked key
aa78c596 TGR	77	(make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$"))
d8169d05 LC	78	(define errsig-rx
	79	;; Note: The fingeprint part (the last element of the line) appeared in
	80	;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
	81	(make-regexp
	82	"^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
	83
	84
b9e1fddf LC	85	(define* (gnupg-verify sig file
	86	#:optional (keyring (current-keyring)))
	87	"Verify signature SIG for FILE against the keys in KEYRING. All the keys in
	88	KEYRING as assumed to be \"trusted\", whether or not they expired or were
	89	revoked. Return a status s-exp if GnuPG failed."
0fdd3bea	90
217b4a15 LC	91	(define (maybe-fingerprint str)
	92	(match (string-trim-both str)
	93	((or "-" "") #f)
	94	(fpr fpr)))
	95
0fdd3bea	96	(define (status-line->sexp line)
0fdd3bea LC	97	(cond ((regexp-exec sigid-rx line)
	98	=>
	99	(lambda (match)
	100	`(signature-id ,(match:substring match 1) ; sig id
	101	,(match:substring match 2) ; date
	102	,(string->number ; timestamp
	103	(match:substring match 3)))))
	104	((regexp-exec goodsig-rx line)
	105	=>
	106	(lambda (match)
	107	`(good-signature ,(match:substring match 1) ; key id
	108	,(match:substring match 2)))) ; user name
	109	((regexp-exec validsig-rx line)
	110	=>
	111	(lambda (match)
	112	`(valid-signature ,(match:substring match 1) ; fingerprint
	113	,(match:substring match 2) ; sig creation date
	114	,(string->number ; timestamp
	115	(match:substring match 3)))))
	116	((regexp-exec expkeysig-rx line)
	117	=>
	118	(lambda (match)
	119	`(expired-key-signature ,(match:substring match 1) ; fingerprint
	120	,(match:substring match 2)))) ; user name
aa78c596 TGR	121	((regexp-exec revkeysig-rx line)
	122	=>
	123	(lambda (match)
	124	`(revoked-key-signature ,(match:substring match 1) ; fingerprint
	125	,(match:substring match 2)))) ; user name
0fdd3bea LC	126	((regexp-exec errsig-rx line)
	127	=>
	128	(lambda (match)
217b4a15	129	`(signature-error ,(match:substring match 1) ; key id
0fdd3bea LC	130	,(match:substring match 2) ; pubkey algo
	131	,(match:substring match 3) ; hash algo
	132	,(match:substring match 4) ; sig class
	133	,(string->number ; timestamp
	134	(match:substring match 5))
	135	,(let ((rc
	136	(string->number ; return code
	137	(match:substring match 6))))
	138	(case rc
	139	((9) 'missing-key)
	140	((4) 'unknown-algorithm)
217b4a15 LC	141	(else rc)))
	142	,(maybe-fingerprint ; fingerprint or #f
	143	(match:substring match 7)))))
0fdd3bea LC	144	(else
	145	`(unparsed-line ,line))))
	146
	147	(define (parse-status input)
	148	(let loop ((line (read-line input))
	149	(result '()))
	150	(if (eof-object? line)
	151	(reverse result)
	152	(loop (read-line input)
	153	(cons (status-line->sexp line) result)))))
	154
b9e1fddf LC	155	(let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
b9e1fddf LC	156	"--keyring" keyring sig file))
0fdd3bea LC	157	(status (parse-status pipe)))
	158	;; Ignore PIPE's exit status since STATUS above should contain all the
	159	;; info we need.
	160	(close-pipe pipe)
	161	status))
	162
	163	(define (gnupg-status-good-signature? status)
	164	"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
9cfa3225 LC	165	a fingerprint/user pair; return #f otherwise."
	166	(match (assq 'valid-signature status)
	167	(('valid-signature fingerprint date timestamp)
	168	(match (or (assq 'good-signature status)
aa78c596 TGR	169	(assq 'expired-key-signature status)
aa78c596 TGR	170	(assq 'revoked-key-signature status))
9cfa3225 LC	171	((_ key-id user) (cons fingerprint user))
	172	(_ #f)))
	173	(_
	174	#f)))
0fdd3bea LC	175
0fdd3bea LC	176	(define (gnupg-status-missing-key? status)
217b4a15 LC	177	"If STATUS denotes a missing-key error, then return the fingerprint of the
217b4a15 LC	178	missing key or its key id if the fingerprint is unavailable."
0fdd3bea LC	179	(any (lambda (sexp)
0fdd3bea LC	180	(match sexp
217b4a15 LC	181	(('signature-error key-id _ ... 'missing-key fingerprint)
217b4a15 LC	182	(or fingerprint key-id))
0fdd3bea LC	183	(_ #f)))
	184	status))
	185
4c91332c MC	186	(define* (gnupg-receive-keys fingerprint/key-id
	187	#:key server (keyring (current-keyring)))
	188	"Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from
	189	GnuPG's default/configured one. The key is added to KEYRING."
b9e1fddf LC	190	(unless (file-exists? keyring)
b9e1fddf LC	191	(mkdir-p (dirname keyring))
4c91332c	192	(call-with-output-file keyring (const #t))) ;create an empty keybox
b9e1fddf	193
4c91332c MC	194	(zero? (apply system*
	195	`(,(%gpg-command)
	196	,@(if server
	197	(list "--keyserver" server)
	198	'())
	199	"--no-default-keyring" "--keyring" ,keyring
	200	"--recv-keys" ,fingerprint/key-id))))
0fdd3bea	201
392b5d8c	202	(define* (gnupg-verify* sig file
b9e1fddf LC	203	#:key
b9e1fddf LC	204	(key-download 'interactive)
4c91332c	205	server
b9e1fddf	206	(keyring (current-keyring)))
0fdd3bea	207	"Like `gnupg-verify', but try downloading the public key if it's missing.
f94f9d67 LC	208	Return two values: 'valid-signature and a fingerprint/name pair upon success,
	209	'missing-key and a fingerprint if the key could not be found, and
	210	'invalid-signature with a fingerprint if the signature is invalid.
	211
	212	KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
	213	values: 'always', 'never', and 'interactive' (default). Return a
	214	fingerprint/user name pair on success and #f otherwise."
0fdd3bea	215	(let ((status (gnupg-verify sig file)))
f94f9d67 LC	216	(match (gnupg-status-good-signature? status)
	217	((fingerprint . user)
	218	(values 'valid-signature (cons fingerprint user)))
	219	(#f
	220	(let ((missing (gnupg-status-missing-key? status)))
	221	(define (download-and-try-again)
	222	;; Download the missing key and try again.
4c91332c	223	(if (gnupg-receive-keys missing #:server server #:keyring keyring)
f94f9d67 LC	224	(match (gnupg-status-good-signature?
	225	(gnupg-verify sig file keyring))
	226	(#f
	227	(values 'invalid-signature missing))
	228	((fingerprint . user)
	229	(values 'valid-signature
	230	(cons fingerprint user))))
	231	(values 'missing-key missing)))
	232
	233	(define (receive?)
	234	(let ((answer
	235	(begin
	236	(format #t (G_ "Would you like to add this key \
b9e1fddf	237	to keyring '~a'?~%")
f94f9d67 LC	238	keyring)
	239	(read-line))))
	240	(string-match (locale-yes-regexp) answer)))
	241
	242	(case key-download
	243	((never)
	244	(values 'missing-key missing))
	245	((always)
	246	(download-and-try-again))
	247	(else
	248	(if (receive?)
	249	(download-and-try-again)
	250	(values 'missing-key missing)))))))))
0fdd3bea LC	251
0fdd3bea LC	252	;;; gnupg.scm ends here