guix/gnupg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   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)
  25   #:use-module (ice-9 i18n)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (guix i18n)
  28   #:use-module ((guix utils) #:select (config-directory))
  29   #:use-module ((guix build utils) #:select (mkdir-p))
  30   #:export (%gpg-command
  31             %openpgp-key-server
  32             current-keyring
  33             gnupg-verify
  34             gnupg-verify*
  35             gnupg-status-good-signature?
  36             gnupg-status-missing-key?))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; GnuPG interface.
  41 ;;;
  42 ;;; Code:
  43
  44 (define %gpg-command
  45   ;; The GnuPG 2.x command-line program name.
  46   (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
  47
  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
  57 (define %openpgp-key-server
  58   ;; The default key server.  Note that keys.gnupg.net appears to be
  59   ;; unreliable.
  60   (make-parameter "pool.sks-keyservers.net"))
  61
  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."
  67
  68   (define (status-line->sexp line)
  69     ;; See file `doc/DETAILS' in GnuPG.
  70     (define sigid-rx
  71       (make-regexp
  72        "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
  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
 135   (let* ((pipe   (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
 136                              "--keyring" keyring sig file))
 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
 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))
 172
 173 (define* (gnupg-verify* sig file
 174                         #:key
 175                         (key-download 'interactive)
 176                         (server (%openpgp-key-server))
 177                         (keyring (current-keyring)))
 178   "Like `gnupg-verify', but try downloading the public key if it's missing.
 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)."
 182   (let ((status (gnupg-verify sig file)))
 183     (or (gnupg-status-good-signature? status)
 184         (let ((missing (gnupg-status-missing-key? status)))
 185           (define (download-and-try-again)
 186             ;; Download the missing key and try again.
 187             (begin
 188               (gnupg-receive-keys missing server keyring)
 189               (gnupg-status-good-signature? (gnupg-verify sig file
 190                                                           keyring))))
 191
 192           (define (receive?)
 193             (let ((answer
 194                    (begin
 195                      (format #t (G_ "Would you like to add this key \
 196 to keyring '~a'?~%")
 197                              keyring)
 198                      (read-line))))
 199               (string-match (locale-yes-regexp) answer)))
 200
 201           (and missing
 202                (case key-download
 203                  ((never) #f)
 204                  ((always)
 205                   (download-and-try-again))
 206                  (else
 207                   (and (receive?)
 208                        (download-and-try-again)))))))))
 209
 210 ;;; gnupg.scm ends here