guix/gnupg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2013, 2014, 2016 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 ui)
  28   #:export (%gpg-command
  29             %openpgp-key-server
  30             gnupg-verify
  31             gnupg-verify*
  32             gnupg-status-good-signature?
  33             gnupg-status-missing-key?))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; GnuPG interface.
  38 ;;;
  39 ;;; Code:
  40
  41 (define %gpg-command
  42   ;; The GnuPG 2.x command-line program name.
  43   (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
  44
  45 (define %openpgp-key-server
  46   ;; The default key server.  Note that keys.gnupg.net appears to be
  47   ;; unreliable.
  48   (make-parameter "pgp.mit.edu"))
  49
  50 (define (gnupg-verify sig file)
  51   "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
  52
  53   (define (status-line->sexp line)
  54     ;; See file `doc/DETAILS' in GnuPG.
  55     (define sigid-rx
  56       (make-regexp
  57        "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
  58     (define goodsig-rx
  59       (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
  60     (define validsig-rx
  61       (make-regexp
  62        "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
  63     (define expkeysig-rx                    ; good signature, but expired key
  64       (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
  65     (define errsig-rx
  66       (make-regexp
  67        "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
  68
  69     (cond ((regexp-exec sigid-rx line)
  70            =>
  71            (lambda (match)
  72              `(signature-id ,(match:substring match 1) ; sig id
  73                             ,(match:substring match 2) ; date
  74                             ,(string->number           ; timestamp
  75                               (match:substring match 3)))))
  76           ((regexp-exec goodsig-rx line)
  77            =>
  78            (lambda (match)
  79              `(good-signature ,(match:substring match 1)    ; key id
  80                               ,(match:substring match 2)))) ; user name
  81           ((regexp-exec validsig-rx line)
  82            =>
  83            (lambda (match)
  84              `(valid-signature ,(match:substring match 1) ; fingerprint
  85                                ,(match:substring match 2) ; sig creation date
  86                                ,(string->number           ; timestamp
  87                                  (match:substring match 3)))))
  88           ((regexp-exec expkeysig-rx line)
  89            =>
  90            (lambda (match)
  91              `(expired-key-signature ,(match:substring match 1) ; fingerprint
  92                                      ,(match:substring match 2)))) ; user name
  93           ((regexp-exec errsig-rx line)
  94            =>
  95            (lambda (match)
  96              `(signature-error ,(match:substring match 1) ; key id or fingerprint
  97                                ,(match:substring match 2) ; pubkey algo
  98                                ,(match:substring match 3) ; hash algo
  99                                ,(match:substring match 4) ; sig class
 100                                ,(string->number           ; timestamp
 101                                  (match:substring match 5))
 102                                ,(let ((rc
 103                                        (string->number ; return code
 104                                         (match:substring match 6))))
 105                                   (case rc
 106                                     ((9) 'missing-key)
 107                                     ((4) 'unknown-algorithm)
 108                                     (else rc))))))
 109           (else
 110            `(unparsed-line ,line))))
 111
 112   (define (parse-status input)
 113     (let loop ((line   (read-line input))
 114                (result '()))
 115       (if (eof-object? line)
 116           (reverse result)
 117           (loop (read-line input)
 118                 (cons (status-line->sexp line) result)))))
 119
 120   (let* ((pipe   (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1"
 121                              "--verify" sig file))
 122          (status (parse-status pipe)))
 123     ;; Ignore PIPE's exit status since STATUS above should contain all the
 124     ;; info we need.
 125     (close-pipe pipe)
 126     status))
 127
 128 (define (gnupg-status-good-signature? status)
 129   "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
 130 a key-id/user pair; return #f otherwise."
 131   (any (lambda (sexp)
 132          (match sexp
 133            (((or 'good-signature 'expired-key-signature) key-id user)
 134             (cons key-id user))
 135            (_ #f)))
 136        status))
 137
 138 (define (gnupg-status-missing-key? status)
 139   "If STATUS denotes a missing-key error, then return the key-id of the
 140 missing key."
 141   (any (lambda (sexp)
 142          (match sexp
 143            (('signature-error key-id _ ...)
 144             key-id)
 145            (_ #f)))
 146        status))
 147
 148 (define (gnupg-receive-keys key-id server)
 149   (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id))
 150
 151 (define* (gnupg-verify* sig file
 152                         #:key (key-download 'interactive)
 153                               (server (%openpgp-key-server)))
 154   "Like `gnupg-verify', but try downloading the public key if it's missing.
 155 Return #t if the signature was good, #f otherwise.  KEY-DOWNLOAD specifies a
 156 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
 157 and 'interactive' (default)."
 158   (let ((status (gnupg-verify sig file)))
 159     (or (gnupg-status-good-signature? status)
 160         (let ((missing (gnupg-status-missing-key? status)))
 161           (define (download-and-try-again)
 162             ;; Download the missing key and try again.
 163             (begin
 164               (gnupg-receive-keys missing server)
 165               (gnupg-status-good-signature? (gnupg-verify sig file))))
 166
 167           (define (receive?)
 168             (let ((answer
 169                    (begin (format #t (G_ "~a~a~%")
 170                                   "Would you like to download this key "
 171                                   "and add it to your keyring?")
 172                           (read-line))))
 173               (string-match (locale-yes-regexp) answer)))
 174
 175           (and missing
 176                (case key-download
 177                  ((never) #f)
 178                  ((always)
 179                   (download-and-try-again))
 180                  (else
 181                   (and (receive?)
 182                        (download-and-try-again)))))))))
 183
 184 ;;; gnupg.scm ends here