guix-devel/guix/gnupg.scm

211 lines
8.2 KiB
Scheme

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix gnupg)
#:use-module (ice-9 popen)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 i18n)
#:use-module (srfi srfi-1)
#:use-module (guix i18n)
#:use-module ((guix utils) #:select (config-directory))
#:use-module ((guix build utils) #:select (mkdir-p))
#:export (%gpg-command
%openpgp-key-server
current-keyring
gnupg-verify
gnupg-verify*
gnupg-status-good-signature?
gnupg-status-missing-key?))
;;; Commentary:
;;;
;;; GnuPG interface.
;;;
;;; Code:
(define %gpg-command
;; The GnuPG 2.x command-line program name.
(make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg")))
(define %gpgv-command
;; The 'gpgv' program.
(make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv")))
(define current-keyring
;; The default keyring of "trusted keys".
(make-parameter (string-append (config-directory #:ensure? #f)
"/gpg/trustedkeys.kbx")))
(define %openpgp-key-server
;; The default key server. Note that keys.gnupg.net appears to be
;; unreliable.
(make-parameter "pgp.mit.edu"))
(define* (gnupg-verify sig file
#:optional (keyring (current-keyring)))
"Verify signature SIG for FILE against the keys in KEYRING. All the keys in
KEYRING as assumed to be \"trusted\", whether or not they expired or were
revoked. Return a status s-exp if GnuPG failed."
(define (status-line->sexp line)
;; See file `doc/DETAILS' in GnuPG.
(define sigid-rx
(make-regexp
"^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
(define goodsig-rx
(make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
(define validsig-rx
(make-regexp
"^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
(define expkeysig-rx ; good signature, but expired key
(make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
(define errsig-rx
(make-regexp
"^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
(cond ((regexp-exec sigid-rx line)
=>
(lambda (match)
`(signature-id ,(match:substring match 1) ; sig id
,(match:substring match 2) ; date
,(string->number ; timestamp
(match:substring match 3)))))
((regexp-exec goodsig-rx line)
=>
(lambda (match)
`(good-signature ,(match:substring match 1) ; key id
,(match:substring match 2)))) ; user name
((regexp-exec validsig-rx line)
=>
(lambda (match)
`(valid-signature ,(match:substring match 1) ; fingerprint
,(match:substring match 2) ; sig creation date
,(string->number ; timestamp
(match:substring match 3)))))
((regexp-exec expkeysig-rx line)
=>
(lambda (match)
`(expired-key-signature ,(match:substring match 1) ; fingerprint
,(match:substring match 2)))) ; user name
((regexp-exec errsig-rx line)
=>
(lambda (match)
`(signature-error ,(match:substring match 1) ; key id or fingerprint
,(match:substring match 2) ; pubkey algo
,(match:substring match 3) ; hash algo
,(match:substring match 4) ; sig class
,(string->number ; timestamp
(match:substring match 5))
,(let ((rc
(string->number ; return code
(match:substring match 6))))
(case rc
((9) 'missing-key)
((4) 'unknown-algorithm)
(else rc))))))
(else
`(unparsed-line ,line))))
(define (parse-status input)
(let loop ((line (read-line input))
(result '()))
(if (eof-object? line)
(reverse result)
(loop (read-line input)
(cons (status-line->sexp line) result)))))
(let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1"
"--keyring" keyring sig file))
(status (parse-status pipe)))
;; Ignore PIPE's exit status since STATUS above should contain all the
;; info we need.
(close-pipe pipe)
status))
(define (gnupg-status-good-signature? status)
"If STATUS, as returned by `gnupg-verify', denotes a good signature, return
a key-id/user pair; return #f otherwise."
(any (lambda (sexp)
(match sexp
(((or 'good-signature 'expired-key-signature) key-id user)
(cons key-id user))
(_ #f)))
status))
(define (gnupg-status-missing-key? status)
"If STATUS denotes a missing-key error, then return the key-id of the
missing key."
(any (lambda (sexp)
(match sexp
(('signature-error key-id _ ...)
key-id)
(_ #f)))
status))
(define* (gnupg-receive-keys key-id server
#:optional (keyring (current-keyring)))
(unless (file-exists? keyring)
(mkdir-p (dirname keyring))
(call-with-output-file keyring (const #t))) ;create an empty keybox
(system* (%gpg-command) "--keyserver" server
"--no-default-keyring" "--keyring" keyring
"--recv-keys" key-id))
(define* (gnupg-verify* sig file
#:key
(key-download 'interactive)
(server (%openpgp-key-server))
(keyring (current-keyring)))
"Like `gnupg-verify', but try downloading the public key if it's missing.
Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
and 'interactive' (default)."
(let ((status (gnupg-verify sig file)))
(or (gnupg-status-good-signature? status)
(let ((missing (gnupg-status-missing-key? status)))
(define (download-and-try-again)
;; Download the missing key and try again.
(begin
(gnupg-receive-keys missing server keyring)
(gnupg-status-good-signature? (gnupg-verify sig file
keyring))))
(define (receive?)
(let ((answer
(begin
(format #t (G_ "Would you like to add this key \
to keyring '~a'?~%")
keyring)
(read-line))))
(string-match (locale-yes-regexp) answer)))
(and missing
(case key-download
((never) #f)
((always)
(download-and-try-again))
(else
(and (receive?)
(download-and-try-again)))))))))
;;; gnupg.scm ends here