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