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 (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 (maybe-fingerprint str)
  69     (match (string-trim-both str)
  70       ((or "-" "") #f)
  71       (fpr         fpr)))
  72
  73   (define (status-line->sexp line)
  74     ;; See file `doc/DETAILS' in GnuPG.
  75     (define sigid-rx
  76       (make-regexp
  77        "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
  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
  86       ;; Note: The fingeprint part (the last element of the line) appeared in
  87       ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing.
  88       (make-regexp
  89        "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)(.*)"))
  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)
 118              `(signature-error ,(match:substring match 1) ; key id
 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)
 130                                     (else rc)))
 131                                ,(maybe-fingerprint ; fingerprint or #f
 132                                  (match:substring match 7)))))
 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
 144   (let* ((pipe   (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
 145                              "--keyring" keyring sig file))
 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
 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)))
 163
 164 (define (gnupg-status-missing-key? status)
 165   "If STATUS denotes a missing-key error, then return the fingerprint of the
 166 missing key or its key id if the fingerprint is unavailable."
 167   (any (lambda (sexp)
 168          (match sexp
 169            (('signature-error key-id _ ... 'missing-key fingerprint)
 170             (or fingerprint key-id))
 171            (_ #f)))
 172        status))
 173
 174 (define* (gnupg-receive-keys fingerprint/key-id server
 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
 182            "--recv-keys" fingerprint/key-id))
 183
 184 (define* (gnupg-verify* sig file
 185                         #:key
 186                         (key-download 'interactive)
 187                         (server (%openpgp-key-server))
 188                         (keyring (current-keyring)))
 189   "Like `gnupg-verify', but try downloading the public key if it's missing.
 190 Return #t if the signature was good, #f otherwise.  KEY-DOWNLOAD specifies a
 191 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
 192 and 'interactive' (default).  Return a fingerprint/user name pair on success
 193 and #f otherwise."
 194   (let ((status (gnupg-verify sig file)))
 195     (or (gnupg-status-good-signature? status)
 196         (let ((missing (gnupg-status-missing-key? status)))
 197           (define (download-and-try-again)
 198             ;; Download the missing key and try again.
 199             (begin
 200               (gnupg-receive-keys missing server keyring)
 201               (gnupg-status-good-signature? (gnupg-verify sig file
 202                                                           keyring))))
 203
 204           (define (receive?)
 205             (let ((answer
 206                    (begin
 207                      (format #t (G_ "Would you like to add this key \
 208 to keyring '~a'?~%")
 209                              keyring)
 210                      (read-line))))
 211               (string-match (locale-yes-regexp) answer)))
 212
 213           (and missing
 214                (case key-download
 215                  ((never) #f)
 216                  ((always)
 217                   (download-and-try-again))
 218                  (else
 219                   (and (receive?)
 220                        (download-and-try-again)))))))))
 221
 222 ;;; gnupg.scm ends here