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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 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 (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:]]+)"))

    (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 or fingerprint
                               ,(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))))))
          (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 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))

(define (gnupg-status-missing-key? status)
  "If STATUS denotes a missing-key error, then return the key-id of the
missing key."
  (any (lambda (sexp)
         (match sexp
           (('signature-error key-id _ ...)
            key-id)
           (_ #f)))
       status))

(define* (gnupg-receive-keys 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" 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)."
  (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
b9e1fddf	2	;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 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 LC	67
	68	(define (status-line->sexp line)
	69	;; See file `doc/DETAILS' in GnuPG.
	70	(define sigid-rx
	71	(make-regexp
27afb11a	72	"^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
0fdd3bea LC	73	(define goodsig-rx
	74	(make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
	75	(define validsig-rx
	76	(make-regexp
	77	"^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
	78	(define expkeysig-rx ; good signature, but expired key
	79	(make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
	80	(define errsig-rx
	81	(make-regexp
	82	"^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
	83
	84	(cond ((regexp-exec sigid-rx line)
	85	=>
	86	(lambda (match)
	87	`(signature-id ,(match:substring match 1) ; sig id
	88	,(match:substring match 2) ; date
	89	,(string->number ; timestamp
	90	(match:substring match 3)))))
	91	((regexp-exec goodsig-rx line)
	92	=>
	93	(lambda (match)
	94	`(good-signature ,(match:substring match 1) ; key id
	95	,(match:substring match 2)))) ; user name
	96	((regexp-exec validsig-rx line)
	97	=>
	98	(lambda (match)
	99	`(valid-signature ,(match:substring match 1) ; fingerprint
	100	,(match:substring match 2) ; sig creation date
	101	,(string->number ; timestamp
	102	(match:substring match 3)))))
	103	((regexp-exec expkeysig-rx line)
	104	=>
	105	(lambda (match)
	106	`(expired-key-signature ,(match:substring match 1) ; fingerprint
	107	,(match:substring match 2)))) ; user name
	108	((regexp-exec errsig-rx line)
	109	=>
	110	(lambda (match)
	111	`(signature-error ,(match:substring match 1) ; key id or fingerprint
	112	,(match:substring match 2) ; pubkey algo
	113	,(match:substring match 3) ; hash algo
	114	,(match:substring match 4) ; sig class
	115	,(string->number ; timestamp
	116	(match:substring match 5))
	117	,(let ((rc
	118	(string->number ; return code
	119	(match:substring match 6))))
	120	(case rc
	121	((9) 'missing-key)
	122	((4) 'unknown-algorithm)
	123	(else rc))))))
	124	(else
	125	`(unparsed-line ,line))))
	126
	127	(define (parse-status input)
	128	(let loop ((line (read-line input))
	129	(result '()))
	130	(if (eof-object? line)
	131	(reverse result)
	132	(loop (read-line input)
	133	(cons (status-line->sexp line) result)))))
	134
b9e1fddf LC	135	(let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
b9e1fddf LC	136	"--keyring" keyring sig file))
0fdd3bea LC	137	(status (parse-status pipe)))
	138	;; Ignore PIPE's exit status since STATUS above should contain all the
	139	;; info we need.
	140	(close-pipe pipe)
	141	status))
	142
	143	(define (gnupg-status-good-signature? status)
	144	"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
	145	a key-id/user pair; return #f otherwise."
	146	(any (lambda (sexp)
	147	(match sexp
	148	(((or 'good-signature 'expired-key-signature) key-id user)
	149	(cons key-id user))
	150	(_ #f)))
	151	status))
	152
	153	(define (gnupg-status-missing-key? status)
	154	"If STATUS denotes a missing-key error, then return the key-id of the
	155	missing key."
	156	(any (lambda (sexp)
	157	(match sexp
	158	(('signature-error key-id _ ...)
	159	key-id)
	160	(_ #f)))
	161	status))
	162
b9e1fddf LC	163	(define* (gnupg-receive-keys key-id server
	164	#:optional (keyring (current-keyring)))
	165	(unless (file-exists? keyring)
	166	(mkdir-p (dirname keyring))
	167	(call-with-output-file keyring (const #t))) ;create an empty keybox
	168
	169	(system* (%gpg-command) "--keyserver" server
	170	"--no-default-keyring" "--keyring" keyring
	171	"--recv-keys" key-id))
0fdd3bea	172
392b5d8c	173	(define* (gnupg-verify* sig file
b9e1fddf LC	174	#:key
	175	(key-download 'interactive)
	176	(server (%openpgp-key-server))
	177	(keyring (current-keyring)))
0fdd3bea	178	"Like `gnupg-verify', but try downloading the public key if it's missing.
392b5d8c NK	179	Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
	180	download policy for missing OpenPGP keys; allowed values: 'always', 'never',
	181	and 'interactive' (default)."
0fdd3bea LC	182	(let ((status (gnupg-verify sig file)))
	183	(or (gnupg-status-good-signature? status)
	184	(let ((missing (gnupg-status-missing-key? status)))
392b5d8c NK	185	(define (download-and-try-again)
	186	;; Download the missing key and try again.
	187	(begin
b9e1fddf LC	188	(gnupg-receive-keys missing server keyring)
	189	(gnupg-status-good-signature? (gnupg-verify sig file
	190	keyring))))
392b5d8c NK	191
	192	(define (receive?)
	193	(let ((answer
b9e1fddf LC	194	(begin
	195	(format #t (G_ "Would you like to add this key \
	196	to keyring '~a'?~%")
	197	keyring)
	198	(read-line))))
392b5d8c NK	199	(string-match (locale-yes-regexp) answer)))
392b5d8c NK	200
0fdd3bea	201	(and missing
392b5d8c NK	202	(case key-download
	203	((never) #f)
	204	((always)
	205	(download-and-try-again))
	206	(else
	207	(and (receive?)
	208	(download-and-try-again)))))))))
0fdd3bea LC	209
0fdd3bea LC	210	;;; gnupg.scm ends here