guix/gnupg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix gnupg)
  20   #:use-module (ice-9 popen)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 regex)
  23   #:use-module (ice-9 rdelim)
  24   #:use-module (srfi srfi-1)
  25   #:export (gnupg-verify
  26             gnupg-verify*
  27             gnupg-status-good-signature?
  28             gnupg-status-missing-key?))
  29
  30 ;;; Commentary:
  31 ;;;
  32 ;;; GnuPG interface.
  33 ;;;
  34 ;;; Code:
  35
  36 (define %gpg-command "gpg2")
  37 (define %openpgp-key-server "keys.gnupg.net")
  38
  39 (define (gnupg-verify sig file)
  40   "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
  41
  42   (define (status-line->sexp line)
  43     ;; See file `doc/DETAILS' in GnuPG.
  44     (define sigid-rx
  45       (make-regexp
  46        "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
  47     (define goodsig-rx
  48       (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
  49     (define validsig-rx
  50       (make-regexp
  51        "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
  52     (define expkeysig-rx                    ; good signature, but expired key
  53       (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
  54     (define errsig-rx
  55       (make-regexp
  56        "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
  57
  58     (cond ((regexp-exec sigid-rx line)
  59            =>
  60            (lambda (match)
  61              `(signature-id ,(match:substring match 1) ; sig id
  62                             ,(match:substring match 2) ; date
  63                             ,(string->number           ; timestamp
  64                               (match:substring match 3)))))
  65           ((regexp-exec goodsig-rx line)
  66            =>
  67            (lambda (match)
  68              `(good-signature ,(match:substring match 1)    ; key id
  69                               ,(match:substring match 2)))) ; user name
  70           ((regexp-exec validsig-rx line)
  71            =>
  72            (lambda (match)
  73              `(valid-signature ,(match:substring match 1) ; fingerprint
  74                                ,(match:substring match 2) ; sig creation date
  75                                ,(string->number           ; timestamp
  76                                  (match:substring match 3)))))
  77           ((regexp-exec expkeysig-rx line)
  78            =>
  79            (lambda (match)
  80              `(expired-key-signature ,(match:substring match 1) ; fingerprint
  81                                      ,(match:substring match 2)))) ; user name
  82           ((regexp-exec errsig-rx line)
  83            =>
  84            (lambda (match)
  85              `(signature-error ,(match:substring match 1) ; key id or fingerprint
  86                                ,(match:substring match 2) ; pubkey algo
  87                                ,(match:substring match 3) ; hash algo
  88                                ,(match:substring match 4) ; sig class
  89                                ,(string->number           ; timestamp
  90                                  (match:substring match 5))
  91                                ,(let ((rc
  92                                        (string->number ; return code
  93                                         (match:substring match 6))))
  94                                   (case rc
  95                                     ((9) 'missing-key)
  96                                     ((4) 'unknown-algorithm)
  97                                     (else rc))))))
  98           (else
  99            `(unparsed-line ,line))))
 100
 101   (define (parse-status input)
 102     (let loop ((line   (read-line input))
 103                (result '()))
 104       (if (eof-object? line)
 105           (reverse result)
 106           (loop (read-line input)
 107                 (cons (status-line->sexp line) result)))))
 108
 109   (let* ((pipe   (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
 110                              "--verify" sig file))
 111          (status (parse-status pipe)))
 112     ;; Ignore PIPE's exit status since STATUS above should contain all the
 113     ;; info we need.
 114     (close-pipe pipe)
 115     status))
 116
 117 (define (gnupg-status-good-signature? status)
 118   "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
 119 a key-id/user pair; return #f otherwise."
 120   (any (lambda (sexp)
 121          (match sexp
 122            (((or 'good-signature 'expired-key-signature) key-id user)
 123             (cons key-id user))
 124            (_ #f)))
 125        status))
 126
 127 (define (gnupg-status-missing-key? status)
 128   "If STATUS denotes a missing-key error, then return the key-id of the
 129 missing key."
 130   (any (lambda (sexp)
 131          (match sexp
 132            (('signature-error key-id _ ...)
 133             key-id)
 134            (_ #f)))
 135        status))
 136
 137 (define (gnupg-receive-keys key-id server)
 138   (system* %gpg-command "--keyserver" server "--recv-keys" key-id))
 139
 140 (define* (gnupg-verify* sig file #:optional (server %openpgp-key-server))
 141   "Like `gnupg-verify', but try downloading the public key if it's missing.
 142 Return #t if the signature was good, #f otherwise."
 143   (let ((status (gnupg-verify sig file)))
 144     (or (gnupg-status-good-signature? status)
 145         (let ((missing (gnupg-status-missing-key? status)))
 146           (and missing
 147                (begin
 148                  ;; Download the missing key and try again.
 149                  (gnupg-receive-keys missing server)
 150                  (gnupg-status-good-signature? (gnupg-verify sig file))))))))
 151
 152 ;;; gnupg.scm ends here