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.
 
 
 
 
 
 

408 lines
16 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2017 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. (define-module (guix pk-crypto)
  19. #:use-module (guix base16)
  20. #:use-module (guix gcrypt)
  21. #:use-module (system foreign)
  22. #:use-module (rnrs bytevectors)
  23. #:use-module (ice-9 match)
  24. #:use-module (ice-9 rdelim)
  25. #:export (canonical-sexp?
  26. error-source
  27. error-string
  28. string->canonical-sexp
  29. canonical-sexp->string
  30. read-file-sexp
  31. number->canonical-sexp
  32. canonical-sexp-car
  33. canonical-sexp-cdr
  34. canonical-sexp-nth
  35. canonical-sexp-nth-data
  36. canonical-sexp-length
  37. canonical-sexp-null?
  38. canonical-sexp-list?
  39. bytevector->hash-data
  40. hash-data->bytevector
  41. key-type
  42. sign
  43. verify
  44. generate-key
  45. find-sexp-token
  46. canonical-sexp->sexp
  47. sexp->canonical-sexp)
  48. #:re-export (gcrypt-version))
  49. ;;; Commentary:
  50. ;;;
  51. ;;; Public key cryptographic routines from GNU Libgcrypt.
  52. ;;;;
  53. ;;; Libgcrypt uses "canonical s-expressions" to represent key material,
  54. ;;; parameters, and data. We keep it as an opaque object to map them to
  55. ;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure
  56. ;;; memory, and (2) the read syntax is different.
  57. ;;;
  58. ;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in
  59. ;;; cases where it is safe to move data out of Libgcrypt---e.g., when
  60. ;;; processing ACL entries, public keys, etc.
  61. ;;;
  62. ;;; Canonical sexps were defined by Rivest et al. in the IETF draft at
  63. ;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI
  64. ;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.)
  65. ;;;
  66. ;;; Code:
  67. ;; Libgcrypt "s-expressions".
  68. (define-wrapped-pointer-type <canonical-sexp>
  69. canonical-sexp?
  70. naked-pointer->canonical-sexp
  71. canonical-sexp->pointer
  72. (lambda (obj port)
  73. ;; Don't print OBJ's external representation: we don't want key material
  74. ;; to leak in backtraces and such.
  75. (format port "#<canonical-sexp ~a | ~a>"
  76. (number->string (object-address obj) 16)
  77. (number->string (pointer-address (canonical-sexp->pointer obj))
  78. 16))))
  79. (define finalize-canonical-sexp!
  80. (libgcrypt-func "gcry_sexp_release"))
  81. (define-inlinable (pointer->canonical-sexp ptr)
  82. "Return a <canonical-sexp> that wraps PTR."
  83. (let* ((sexp (naked-pointer->canonical-sexp ptr))
  84. (ptr* (canonical-sexp->pointer sexp)))
  85. ;; Did we already have a <canonical-sexp> object for PTR?
  86. (when (equal? ptr ptr*)
  87. ;; No, so we can safely add a finalizer (in Guile 2.0.9
  88. ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the
  89. ;; existing one.)
  90. (set-pointer-finalizer! ptr finalize-canonical-sexp!))
  91. sexp))
  92. (define error-source
  93. (let* ((ptr (libgcrypt-func "gcry_strsource"))
  94. (proc (pointer->procedure '* ptr (list int))))
  95. (lambda (err)
  96. "Return the error source (a string) for ERR, an error code as thrown
  97. along with 'gcry-error'."
  98. (pointer->string (proc err)))))
  99. (define error-string
  100. (let* ((ptr (libgcrypt-func "gcry_strerror"))
  101. (proc (pointer->procedure '* ptr (list int))))
  102. (lambda (err)
  103. "Return the error description (a string) for ERR, an error code as
  104. thrown along with 'gcry-error'."
  105. (pointer->string (proc err)))))
  106. (define string->canonical-sexp
  107. (let* ((ptr (libgcrypt-func "gcry_sexp_new"))
  108. (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
  109. (lambda (str)
  110. "Parse STR and return the corresponding gcrypt s-expression."
  111. ;; When STR comes from 'canonical-sexp->string', it may contain
  112. ;; characters that are really meant to be interpreted as bytes as in a C
  113. ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the
  114. ;; characters are preserved.
  115. (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
  116. (err (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
  117. (if (= 0 err)
  118. (pointer->canonical-sexp (dereference-pointer sexp))
  119. (throw 'gcry-error 'string->canonical-sexp err))))))
  120. (define-syntax GCRYSEXP_FMT_ADVANCED
  121. (identifier-syntax 3))
  122. (define canonical-sexp->string
  123. (let* ((ptr (libgcrypt-func "gcry_sexp_sprint"))
  124. (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
  125. (lambda (sexp)
  126. "Return a textual representation of SEXP."
  127. (let loop ((len 1024))
  128. (let* ((buf (bytevector->pointer (make-bytevector len)))
  129. (size (proc (canonical-sexp->pointer sexp)
  130. GCRYSEXP_FMT_ADVANCED buf len)))
  131. (if (zero? size)
  132. (loop (* len 2))
  133. (pointer->string buf size "ISO-8859-1")))))))
  134. (define (read-file-sexp file)
  135. "Return the canonical sexp read from FILE."
  136. (call-with-input-file file
  137. (compose string->canonical-sexp
  138. read-string)))
  139. (define canonical-sexp-car
  140. (let* ((ptr (libgcrypt-func "gcry_sexp_car"))
  141. (proc (pointer->procedure '* ptr '(*))))
  142. (lambda (lst)
  143. "Return the first element of LST, an sexp, if that element is a list;
  144. return #f if LST or its first element is not a list (this is different from
  145. the usual Lisp 'car'.)"
  146. (let ((result (proc (canonical-sexp->pointer lst))))
  147. (if (null-pointer? result)
  148. #f
  149. (pointer->canonical-sexp result))))))
  150. (define canonical-sexp-cdr
  151. (let* ((ptr (libgcrypt-func "gcry_sexp_cdr"))
  152. (proc (pointer->procedure '* ptr '(*))))
  153. (lambda (lst)
  154. "Return the tail of LST, an sexp, or #f if LST is not a list."
  155. (let ((result (proc (canonical-sexp->pointer lst))))
  156. (if (null-pointer? result)
  157. #f
  158. (pointer->canonical-sexp result))))))
  159. (define canonical-sexp-nth
  160. (let* ((ptr (libgcrypt-func "gcry_sexp_nth"))
  161. (proc (pointer->procedure '* ptr `(* ,int))))
  162. (lambda (lst index)
  163. "Return the INDEXth nested element of LST, an s-expression. Return #f
  164. if that element does not exist, or if it's an atom. (Note: this is obviously
  165. different from Scheme's 'list-ref'.)"
  166. (let ((result (proc (canonical-sexp->pointer lst) index)))
  167. (if (null-pointer? result)
  168. #f
  169. (pointer->canonical-sexp result))))))
  170. (define (dereference-size_t p)
  171. "Return the size_t value pointed to by P."
  172. (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
  173. 0 (native-endianness)
  174. (sizeof size_t)))
  175. (define canonical-sexp-length
  176. (let* ((ptr (libgcrypt-func "gcry_sexp_length"))
  177. (proc (pointer->procedure int ptr '(*))))
  178. (lambda (sexp)
  179. "Return the length of SEXP if it's a list (including the empty list);
  180. return zero if SEXP is an atom."
  181. (proc (canonical-sexp->pointer sexp)))))
  182. (define token-string?
  183. (let ((token-cs (char-set-union char-set:digit
  184. char-set:letter
  185. (char-set #\- #\. #\/ #\_
  186. #\: #\* #\+ #\=))))
  187. (lambda (str)
  188. "Return #t if STR is a token as per Section 4.3 of
  189. <http://people.csail.mit.edu/rivest/Sexp.txt>."
  190. (and (not (string-null? str))
  191. (string-every token-cs str)
  192. (not (char-set-contains? char-set:digit (string-ref str 0)))))))
  193. (define canonical-sexp-nth-data
  194. (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data"))
  195. (proc (pointer->procedure '* ptr `(* ,int *))))
  196. (lambda (lst index)
  197. "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
  198. \"octet string\") the INDEXth data element (atom) of LST, an s-expression.
  199. Return #f if that element does not exist, or if it's a list."
  200. (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
  201. (result (proc (canonical-sexp->pointer lst) index size*)))
  202. (if (null-pointer? result)
  203. #f
  204. (let* ((len (dereference-size_t size*))
  205. (str (pointer->string result len "ISO-8859-1")))
  206. ;; The sexp spec speaks of "tokens" and "octet strings".
  207. ;; Sometimes these octet strings are actual strings (text),
  208. ;; sometimes they're bytevectors, and sometimes they're
  209. ;; multi-precision integers (MPIs). Only the application knows.
  210. ;; However, for convenience, we return a symbol when a token is
  211. ;; encountered since tokens are frequent (at least in the 'car'
  212. ;; of each sexp.)
  213. (if (token-string? str)
  214. (string->symbol str) ; an sexp "token"
  215. (bytevector-copy ; application data, textual or binary
  216. (pointer->bytevector result len)))))))))
  217. (define (number->canonical-sexp number)
  218. "Return an s-expression representing NUMBER."
  219. (string->canonical-sexp (string-append "#" (number->string number 16) "#")))
  220. (define* (bytevector->hash-data bv
  221. #:optional
  222. (hash-algo "sha256")
  223. #:key (key-type 'ecc))
  224. "Given BV, a bytevector containing a hash of type HASH-ALGO, return an
  225. s-expression suitable for use as the 'data' argument for 'sign'. KEY-TYPE
  226. must be a symbol: 'dsa, 'ecc, or 'rsa."
  227. (string->canonical-sexp
  228. (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
  229. (case key-type
  230. ((ecc dsa) "rfc6979")
  231. ((rsa) "pkcs1")
  232. (else (error "unknown key type" key-type)))
  233. hash-algo
  234. (bytevector->base16-string bv))))
  235. (define (key-type sexp)
  236. "Return a symbol denoting the type of public or private key represented by
  237. SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
  238. (case (canonical-sexp-nth-data sexp 0)
  239. ((public-key private-key)
  240. (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
  241. (else #f)))
  242. (define* (hash-data->bytevector data)
  243. "Return two values: the hash value (a bytevector), and the hash algorithm (a
  244. string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
  245. Return #f if DATA does not conform."
  246. (let ((hash (find-sexp-token data 'hash)))
  247. (if hash
  248. (let ((algo (canonical-sexp-nth-data hash 1))
  249. (value (canonical-sexp-nth-data hash 2)))
  250. (values value (symbol->string algo)))
  251. (values #f #f))))
  252. (define sign
  253. (let* ((ptr (libgcrypt-func "gcry_pk_sign"))
  254. (proc (pointer->procedure int ptr '(* * *))))
  255. (lambda (data secret-key)
  256. "Sign DATA, a canonical s-expression representing a suitable hash, with
  257. SECRET-KEY (a canonical s-expression whose car is 'private-key'.) Note that
  258. DATA must be a 'data' s-expression, as returned by
  259. 'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
  260. (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
  261. (err (proc sig (canonical-sexp->pointer data)
  262. (canonical-sexp->pointer secret-key))))
  263. (if (= 0 err)
  264. (pointer->canonical-sexp (dereference-pointer sig))
  265. (throw 'gcry-error 'sign err))))))
  266. (define verify
  267. (let* ((ptr (libgcrypt-func "gcry_pk_verify"))
  268. (proc (pointer->procedure int ptr '(* * *))))
  269. (lambda (signature data public-key)
  270. "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
  271. which are gcrypt s-expressions."
  272. (zero? (proc (canonical-sexp->pointer signature)
  273. (canonical-sexp->pointer data)
  274. (canonical-sexp->pointer public-key))))))
  275. (define generate-key
  276. (let* ((ptr (libgcrypt-func "gcry_pk_genkey"))
  277. (proc (pointer->procedure int ptr '(* *))))
  278. (lambda (params)
  279. "Return as an s-expression a new key pair for PARAMS. PARAMS must be an
  280. s-expression like: (genkey (rsa (nbits 4:2048)))."
  281. (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
  282. (err (proc key (canonical-sexp->pointer params))))
  283. (if (zero? err)
  284. (pointer->canonical-sexp (dereference-pointer key))
  285. (throw 'gcry-error 'generate-key err))))))
  286. (define find-sexp-token
  287. (let* ((ptr (libgcrypt-func "gcry_sexp_find_token"))
  288. (proc (pointer->procedure '* ptr `(* * ,size_t))))
  289. (lambda (sexp token)
  290. "Find in SEXP the first element whose 'car' is TOKEN and return it;
  291. return #f if not found."
  292. (let* ((token (string->pointer (symbol->string token)))
  293. (res (proc (canonical-sexp->pointer sexp) token 0)))
  294. (if (null-pointer? res)
  295. #f
  296. (pointer->canonical-sexp res))))))
  297. (define-inlinable (canonical-sexp-null? sexp)
  298. "Return #t if SEXP is the empty-list sexp."
  299. (null-pointer? (canonical-sexp->pointer sexp)))
  300. (define (canonical-sexp-list? sexp)
  301. "Return #t if SEXP is a list."
  302. (or (canonical-sexp-null? sexp)
  303. (> (canonical-sexp-length sexp) 0)))
  304. (define (canonical-sexp-fold proc seed sexp)
  305. "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
  306. (if (canonical-sexp-list? sexp)
  307. (let ((len (canonical-sexp-length sexp)))
  308. (let loop ((index 0)
  309. (result seed))
  310. (if (= index len)
  311. result
  312. (loop (+ 1 index)
  313. ;; XXX: Call 'nth-data' *before* 'nth' to work around
  314. ;; <https://bugs.g10code.com/gnupg/issue1594>, which
  315. ;; affects 1.6.0 and earlier versions.
  316. (proc (or (canonical-sexp-nth-data sexp index)
  317. (canonical-sexp-nth sexp index))
  318. result)))))
  319. (error "sexp is not a list" sexp)))
  320. (define (canonical-sexp->sexp sexp)
  321. "Return a Scheme sexp corresponding to SEXP. This is particularly useful to
  322. compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
  323. use pattern matching."
  324. (if (canonical-sexp-list? sexp)
  325. (reverse
  326. (canonical-sexp-fold (lambda (item result)
  327. (cons (if (canonical-sexp? item)
  328. (canonical-sexp->sexp item)
  329. item)
  330. result))
  331. '()
  332. sexp))
  333. ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
  334. ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
  335. (let ((sexp (string->canonical-sexp
  336. (string-append "(" (canonical-sexp->string sexp)
  337. ")"))))
  338. (or (canonical-sexp-nth-data sexp 0)
  339. (canonical-sexp-nth sexp 0)))))
  340. (define (sexp->canonical-sexp sexp)
  341. "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
  342. 'canonical-sexp->sexp'."
  343. ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
  344. ;; much better.
  345. (string->canonical-sexp
  346. (call-with-output-string
  347. (lambda (port)
  348. (define (write item)
  349. (cond ((list? item)
  350. (display "(" port)
  351. (for-each write item)
  352. (display ")" port))
  353. ((symbol? item)
  354. (format port " ~a" item))
  355. ((bytevector? item)
  356. (format port " #~a#"
  357. (bytevector->base16-string item)))
  358. (else
  359. (error "unsupported sexp item type" item))))
  360. (write sexp)))))
  361. (define (gcrypt-error-printer port key args default-printer)
  362. "Print the gcrypt error specified by ARGS."
  363. (match args
  364. ((proc err)
  365. (format port "In procedure ~a: ~a: ~a"
  366. proc (error-source err) (error-string err)))))
  367. (set-exception-printer! 'gcry-error gcrypt-error-printer)
  368. ;;; pk-crypto.scm ends here