[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"))

(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)
    ;; 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:]]+)(.*)"))

    (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)))
  (unless (file-exists? keyring)
    (mkdir-p (dirname keyring))
    (call-with-output-file keyring (const #t)))   ;create an empty keybox

  (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.  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)))
          (define (download-and-try-again)
            ;; Download the missing key and try again.
            (begin
              (gnupg-receive-keys missing server keyring)
              (gnupg-status-good-signature? (gnupg-verify sig file
                                                          keyring))))

          (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)))

          (and missing
               (case key-download
                 ((never) #f)
                 ((always)
                  (download-and-try-again))
                 (else
                  (and (receive?)
                       (download-and-try-again)))))))))

;;; 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
b9e1fddf LC	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."
0fdd3bea	67
217b4a15 LC	68	(define (maybe-fingerprint str)
	69	(match (string-trim-both str)
	70	((or "-" "") #f)
	71	(fpr fpr)))
	72
0fdd3bea LC	73	(define (status-line->sexp line)
	74	;; See file `doc/DETAILS' in GnuPG.
	75	(define sigid-rx
	76	(make-regexp
27afb11a	77	"^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
0fdd3bea LC	78	(define goodsig-rx
	79	(make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
	80	(define validsig-rx
	81	(make-regexp
	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:]]+) (.*)$"))
	85	(define errsig-rx
217b4a15 LC	86	;; Note: The fingeprint part (the last element of the line) appeared in
217b4a15 LC	87	;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
0fdd3bea	88	(make-regexp
217b4a15	89	"^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
0fdd3bea LC	90
	91	(cond ((regexp-exec sigid-rx line)
	92	=>
	93	(lambda (match)
	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)
	99	=>
	100	(lambda (match)
	101	`(good-signature ,(match:substring match 1) ; key id
	102	,(match:substring match 2)))) ; user name
	103	((regexp-exec validsig-rx line)
	104	=>
	105	(lambda (match)
	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)
	111	=>
	112	(lambda (match)
	113	`(expired-key-signature ,(match:substring match 1) ; fingerprint
	114	,(match:substring match 2)))) ; user name
	115	((regexp-exec errsig-rx line)
	116	=>
	117	(lambda (match)
217b4a15	118	`(signature-error ,(match:substring match 1) ; key id
0fdd3bea LC	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))
	124	,(let ((rc
	125	(string->number ; return code
	126	(match:substring match 6))))
	127	(case rc
	128	((9) 'missing-key)
	129	((4) 'unknown-algorithm)
217b4a15 LC	130	(else rc)))
	131	,(maybe-fingerprint ; fingerprint or #f
	132	(match:substring match 7)))))
0fdd3bea LC	133	(else
	134	`(unparsed-line ,line))))
	135
	136	(define (parse-status input)
	137	(let loop ((line (read-line input))
	138	(result '()))
	139	(if (eof-object? line)
	140	(reverse result)
	141	(loop (read-line input)
	142	(cons (status-line->sexp line) result)))))
	143
b9e1fddf LC	144	(let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
b9e1fddf LC	145	"--keyring" keyring sig file))
0fdd3bea LC	146	(status (parse-status pipe)))
	147	;; Ignore PIPE's exit status since STATUS above should contain all the
	148	;; info we need.
	149	(close-pipe pipe)
	150	status))
	151
	152	(define (gnupg-status-good-signature? status)
	153	"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
9cfa3225 LC	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))
	160	(_ #f)))
	161	(_
	162	#f)))
0fdd3bea LC	163
0fdd3bea LC	164	(define (gnupg-status-missing-key? status)
217b4a15 LC	165	"If STATUS denotes a missing-key error, then return the fingerprint of the
217b4a15 LC	166	missing key or its key id if the fingerprint is unavailable."
0fdd3bea LC	167	(any (lambda (sexp)
0fdd3bea LC	168	(match sexp
217b4a15 LC	169	(('signature-error key-id _ ... 'missing-key fingerprint)
217b4a15 LC	170	(or fingerprint key-id))
0fdd3bea LC	171	(_ #f)))
	172	status))
	173
217b4a15	174	(define* (gnupg-receive-keys fingerprint/key-id server
b9e1fddf LC	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
	179
	180	(system* (%gpg-command) "--keyserver" server
	181	"--no-default-keyring" "--keyring" keyring
217b4a15	182	"--recv-keys" fingerprint/key-id))
0fdd3bea	183
392b5d8c	184	(define* (gnupg-verify* sig file
b9e1fddf LC	185	#:key
	186	(key-download 'interactive)
	187	(server (%openpgp-key-server))
	188	(keyring (current-keyring)))
0fdd3bea	189	"Like `gnupg-verify', but try downloading the public key if it's missing.
392b5d8c NK	190	Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
392b5d8c NK	191	download policy for missing OpenPGP keys; allowed values: 'always', 'never',
9cfa3225 LC	192	and 'interactive' (default). Return a fingerprint/user name pair on success
9cfa3225 LC	193	and #f otherwise."
0fdd3bea LC	194	(let ((status (gnupg-verify sig file)))
	195	(or (gnupg-status-good-signature? status)
	196	(let ((missing (gnupg-status-missing-key? status)))
392b5d8c NK	197	(define (download-and-try-again)
	198	;; Download the missing key and try again.
	199	(begin
b9e1fddf LC	200	(gnupg-receive-keys missing server keyring)
	201	(gnupg-status-good-signature? (gnupg-verify sig file
	202	keyring))))
392b5d8c NK	203
	204	(define (receive?)
	205	(let ((answer
b9e1fddf LC	206	(begin
	207	(format #t (G_ "Would you like to add this key \
	208	to keyring '~a'?~%")
	209	keyring)
	210	(read-line))))
392b5d8c NK	211	(string-match (locale-yes-regexp) answer)))
392b5d8c NK	212
0fdd3bea	213	(and missing
392b5d8c NK	214	(case key-download
	215	((never) #f)
	216	((always)
	217	(download-and-try-again))
	218	(else
	219	(and (receive?)
	220	(download-and-try-again)))))))))
0fdd3bea LC	221
0fdd3bea LC	222	;;; gnupg.scm ends here