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.
 
 
 
 
 
 

416 lines
16 KiB

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