You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

185 lines
7.1 KiB

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