| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 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 (status-line->sexp line) |
| 69 | ;; See file `doc/DETAILS' in GnuPG. |
| 70 | (define sigid-rx |
| 71 | (make-regexp |
| 72 | "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9+/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) |
| 73 | (define goodsig-rx |
| 74 | (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) |
| 75 | (define validsig-rx |
| 76 | (make-regexp |
| 77 | "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) |
| 78 | (define expkeysig-rx ; good signature, but expired key |
| 79 | (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) |
| 80 | (define errsig-rx |
| 81 | (make-regexp |
| 82 | "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)")) |
| 83 | |
| 84 | (cond ((regexp-exec sigid-rx line) |
| 85 | => |
| 86 | (lambda (match) |
| 87 | `(signature-id ,(match:substring match 1) ; sig id |
| 88 | ,(match:substring match 2) ; date |
| 89 | ,(string->number ; timestamp |
| 90 | (match:substring match 3))))) |
| 91 | ((regexp-exec goodsig-rx line) |
| 92 | => |
| 93 | (lambda (match) |
| 94 | `(good-signature ,(match:substring match 1) ; key id |
| 95 | ,(match:substring match 2)))) ; user name |
| 96 | ((regexp-exec validsig-rx line) |
| 97 | => |
| 98 | (lambda (match) |
| 99 | `(valid-signature ,(match:substring match 1) ; fingerprint |
| 100 | ,(match:substring match 2) ; sig creation date |
| 101 | ,(string->number ; timestamp |
| 102 | (match:substring match 3))))) |
| 103 | ((regexp-exec expkeysig-rx line) |
| 104 | => |
| 105 | (lambda (match) |
| 106 | `(expired-key-signature ,(match:substring match 1) ; fingerprint |
| 107 | ,(match:substring match 2)))) ; user name |
| 108 | ((regexp-exec errsig-rx line) |
| 109 | => |
| 110 | (lambda (match) |
| 111 | `(signature-error ,(match:substring match 1) ; key id or fingerprint |
| 112 | ,(match:substring match 2) ; pubkey algo |
| 113 | ,(match:substring match 3) ; hash algo |
| 114 | ,(match:substring match 4) ; sig class |
| 115 | ,(string->number ; timestamp |
| 116 | (match:substring match 5)) |
| 117 | ,(let ((rc |
| 118 | (string->number ; return code |
| 119 | (match:substring match 6)))) |
| 120 | (case rc |
| 121 | ((9) 'missing-key) |
| 122 | ((4) 'unknown-algorithm) |
| 123 | (else rc)))))) |
| 124 | (else |
| 125 | `(unparsed-line ,line)))) |
| 126 | |
| 127 | (define (parse-status input) |
| 128 | (let loop ((line (read-line input)) |
| 129 | (result '())) |
| 130 | (if (eof-object? line) |
| 131 | (reverse result) |
| 132 | (loop (read-line input) |
| 133 | (cons (status-line->sexp line) result))))) |
| 134 | |
| 135 | (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1" |
| 136 | "--keyring" keyring sig file)) |
| 137 | (status (parse-status pipe))) |
| 138 | ;; Ignore PIPE's exit status since STATUS above should contain all the |
| 139 | ;; info we need. |
| 140 | (close-pipe pipe) |
| 141 | status)) |
| 142 | |
| 143 | (define (gnupg-status-good-signature? status) |
| 144 | "If STATUS, as returned by `gnupg-verify', denotes a good signature, return |
| 145 | a key-id/user pair; return #f otherwise." |
| 146 | (any (lambda (sexp) |
| 147 | (match sexp |
| 148 | (((or 'good-signature 'expired-key-signature) key-id user) |
| 149 | (cons key-id user)) |
| 150 | (_ #f))) |
| 151 | status)) |
| 152 | |
| 153 | (define (gnupg-status-missing-key? status) |
| 154 | "If STATUS denotes a missing-key error, then return the key-id of the |
| 155 | missing key." |
| 156 | (any (lambda (sexp) |
| 157 | (match sexp |
| 158 | (('signature-error key-id _ ...) |
| 159 | key-id) |
| 160 | (_ #f))) |
| 161 | status)) |
| 162 | |
| 163 | (define* (gnupg-receive-keys key-id server |
| 164 | #:optional (keyring (current-keyring))) |
| 165 | (unless (file-exists? keyring) |
| 166 | (mkdir-p (dirname keyring)) |
| 167 | (call-with-output-file keyring (const #t))) ;create an empty keybox |
| 168 | |
| 169 | (system* (%gpg-command) "--keyserver" server |
| 170 | "--no-default-keyring" "--keyring" keyring |
| 171 | "--recv-keys" key-id)) |
| 172 | |
| 173 | (define* (gnupg-verify* sig file |
| 174 | #:key |
| 175 | (key-download 'interactive) |
| 176 | (server (%openpgp-key-server)) |
| 177 | (keyring (current-keyring))) |
| 178 | "Like `gnupg-verify', but try downloading the public key if it's missing. |
| 179 | Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a |
| 180 | download policy for missing OpenPGP keys; allowed values: 'always', 'never', |
| 181 | and 'interactive' (default)." |
| 182 | (let ((status (gnupg-verify sig file))) |
| 183 | (or (gnupg-status-good-signature? status) |
| 184 | (let ((missing (gnupg-status-missing-key? status))) |
| 185 | (define (download-and-try-again) |
| 186 | ;; Download the missing key and try again. |
| 187 | (begin |
| 188 | (gnupg-receive-keys missing server keyring) |
| 189 | (gnupg-status-good-signature? (gnupg-verify sig file |
| 190 | keyring)))) |
| 191 | |
| 192 | (define (receive?) |
| 193 | (let ((answer |
| 194 | (begin |
| 195 | (format #t (G_ "Would you like to add this key \ |
| 196 | to keyring '~a'?~%") |
| 197 | keyring) |
| 198 | (read-line)))) |
| 199 | (string-match (locale-yes-regexp) answer))) |
| 200 | |
| 201 | (and missing |
| 202 | (case key-download |
| 203 | ((never) #f) |
| 204 | ((always) |
| 205 | (download-and-try-again)) |
| 206 | (else |
| 207 | (and (receive?) |
| 208 | (download-and-try-again))))))))) |
| 209 | |
| 210 | ;;; gnupg.scm ends here |