guix/gnupg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 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 ;; 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
  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."
  86
  87   (define (maybe-fingerprint str)
  88     (match (string-trim-both str)
  89       ((or "-" "") #f)
  90       (fpr         fpr)))
  91
  92   (define (status-line->sexp line)
  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)
 120              `(signature-error ,(match:substring match 1) ; key id
 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)
 132                                     (else rc)))
 133                                ,(maybe-fingerprint ; fingerprint or #f
 134                                  (match:substring match 7)))))
 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
 146   (let* ((pipe   (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
 147                              "--keyring" keyring sig file))
 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
 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)))
 165
 166 (define (gnupg-status-missing-key? status)
 167   "If STATUS denotes a missing-key error, then return the fingerprint of the
 168 missing key or its key id if the fingerprint is unavailable."
 169   (any (lambda (sexp)
 170          (match sexp
 171            (('signature-error key-id _ ... 'missing-key fingerprint)
 172             (or fingerprint key-id))
 173            (_ #f)))
 174        status))
 175
 176 (define* (gnupg-receive-keys fingerprint/key-id server
 177                              #:optional (keyring (current-keyring)))
 178   "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
 179 KEYRING."
 180   (unless (file-exists? keyring)
 181     (mkdir-p (dirname keyring))
 182     (call-with-output-file keyring (const #t)))   ;create an empty keybox
 183
 184   (zero? (system* (%gpg-command) "--keyserver" server
 185                   "--no-default-keyring" "--keyring" keyring
 186                   "--recv-keys" fingerprint/key-id)))
 187
 188 (define* (gnupg-verify* sig file
 189                         #:key
 190                         (key-download 'interactive)
 191                         (server (%openpgp-key-server))
 192                         (keyring (current-keyring)))
 193   "Like `gnupg-verify', but try downloading the public key if it's missing.
 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."
 201   (let ((status (gnupg-verify sig file)))
 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 \
 223 to keyring '~a'?~%")
 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)))))))))
 237
 238 ;;; gnupg.scm ends here