pk-crypto.scm 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of guile-gcrypt.
  5. ;;;
  6. ;;; guile-gcrypt 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
  9. ;;; (at your option) any later version.
  10. ;;;
  11. ;;; guile-gcrypt 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 GNU
  14. ;;; General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gcrypt pk-crypto)
  19. #:use-module (gcrypt base16)
  20. #:use-module (gcrypt common)
  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 string->canonical-sexp
  93. (let* ((ptr (libgcrypt-func "gcry_sexp_new"))
  94. (proc (pointer->procedure int ptr `(* * ,size_t ,int))))
  95. (lambda (str)
  96. "Parse STR and return the corresponding gcrypt s-expression."
  97. ;; When STR comes from 'canonical-sexp->string', it may contain
  98. ;; characters that are really meant to be interpreted as bytes as in a C
  99. ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the
  100. ;; characters are preserved.
  101. (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
  102. (err (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
  103. (if (= 0 err)
  104. (pointer->canonical-sexp (dereference-pointer sexp))
  105. (throw 'gcry-error 'string->canonical-sexp err))))))
  106. (define-syntax GCRYSEXP_FMT_ADVANCED
  107. (identifier-syntax 3))
  108. (define canonical-sexp->string
  109. (let* ((ptr (libgcrypt-func "gcry_sexp_sprint"))
  110. (proc (pointer->procedure size_t ptr `(* ,int * ,size_t))))
  111. (lambda (sexp)
  112. "Return a textual representation of SEXP."
  113. (let loop ((len 1024))
  114. (let* ((buf (bytevector->pointer (make-bytevector len)))
  115. (size (proc (canonical-sexp->pointer sexp)
  116. GCRYSEXP_FMT_ADVANCED buf len)))
  117. (if (zero? size)
  118. (loop (* len 2))
  119. (pointer->string buf size "ISO-8859-1")))))))
  120. (define (read-file-sexp file)
  121. "Return the canonical sexp read from FILE."
  122. (call-with-input-file file
  123. (compose string->canonical-sexp
  124. read-string)))
  125. (define canonical-sexp-car
  126. (let* ((ptr (libgcrypt-func "gcry_sexp_car"))
  127. (proc (pointer->procedure '* ptr '(*))))
  128. (lambda (lst)
  129. "Return the first element of LST, an sexp, if that element is a list;
  130. return #f if LST or its first element is not a list (this is different from
  131. the usual Lisp 'car'.)"
  132. (let ((result (proc (canonical-sexp->pointer lst))))
  133. (if (null-pointer? result)
  134. #f
  135. (pointer->canonical-sexp result))))))
  136. (define canonical-sexp-cdr
  137. (let* ((ptr (libgcrypt-func "gcry_sexp_cdr"))
  138. (proc (pointer->procedure '* ptr '(*))))
  139. (lambda (lst)
  140. "Return the tail of LST, an sexp, or #f if LST is not a list."
  141. (let ((result (proc (canonical-sexp->pointer lst))))
  142. (if (null-pointer? result)
  143. #f
  144. (pointer->canonical-sexp result))))))
  145. (define canonical-sexp-nth
  146. (let* ((ptr (libgcrypt-func "gcry_sexp_nth"))
  147. (proc (pointer->procedure '* ptr `(* ,int))))
  148. (lambda (lst index)
  149. "Return the INDEXth nested element of LST, an s-expression. Return #f
  150. if that element does not exist, or if it's an atom. (Note: this is obviously
  151. different from Scheme's 'list-ref'.)"
  152. (let ((result (proc (canonical-sexp->pointer lst) index)))
  153. (if (null-pointer? result)
  154. #f
  155. (pointer->canonical-sexp result))))))
  156. (define (dereference-size_t p)
  157. "Return the size_t value pointed to by P."
  158. (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
  159. 0 (native-endianness)
  160. (sizeof size_t)))
  161. (define canonical-sexp-length
  162. (let* ((ptr (libgcrypt-func "gcry_sexp_length"))
  163. (proc (pointer->procedure int ptr '(*))))
  164. (lambda (sexp)
  165. "Return the length of SEXP if it's a list (including the empty list);
  166. return zero if SEXP is an atom."
  167. (proc (canonical-sexp->pointer sexp)))))
  168. (define token-string?
  169. (let ((token-cs (char-set-union char-set:digit
  170. char-set:letter
  171. (char-set #\- #\. #\/ #\_
  172. #\: #\* #\+ #\=))))
  173. (lambda (str)
  174. "Return #t if STR is a token as per Section 4.3 of
  175. <http://people.csail.mit.edu/rivest/Sexp.txt>."
  176. (and (not (string-null? str))
  177. (string-every token-cs str)
  178. (not (char-set-contains? char-set:digit (string-ref str 0)))))))
  179. (define canonical-sexp-nth-data
  180. (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data"))
  181. (proc (pointer->procedure '* ptr `(* ,int *))))
  182. (lambda (lst index)
  183. "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
  184. \"octet string\") the INDEXth data element (atom) of LST, an s-expression.
  185. Return #f if that element does not exist, or if it's a list."
  186. (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
  187. (result (proc (canonical-sexp->pointer lst) index size*)))
  188. (if (null-pointer? result)
  189. #f
  190. (let* ((len (dereference-size_t size*))
  191. (str (pointer->string result len "ISO-8859-1")))
  192. ;; The sexp spec speaks of "tokens" and "octet strings".
  193. ;; Sometimes these octet strings are actual strings (text),
  194. ;; sometimes they're bytevectors, and sometimes they're
  195. ;; multi-precision integers (MPIs). Only the application knows.
  196. ;; However, for convenience, we return a symbol when a token is
  197. ;; encountered since tokens are frequent (at least in the 'car'
  198. ;; of each sexp.)
  199. (if (token-string? str)
  200. (string->symbol str) ; an sexp "token"
  201. (bytevector-copy ; application data, textual or binary
  202. (pointer->bytevector result len)))))))))
  203. (define (number->canonical-sexp number)
  204. "Return an s-expression representing NUMBER."
  205. (let ((hex-number
  206. (match (number->string number 16)
  207. ;; Append a 0 if necessary. For whatever reason gcrypt
  208. ;; rejects hex numbers that don't have an even number of
  209. ;; digits.
  210. ((? (lambda (s) (odd? (string-length s))) odd-string)
  211. (string-append "0" odd-string))
  212. (even-str even-str))))
  213. (string->canonical-sexp (string-append "#" hex-number "#"))))
  214. (define* (bytevector->hash-data bv
  215. #:optional
  216. (hash-algo "sha256")
  217. #:key (key-type 'ecc))
  218. "Given BV, a bytevector containing a hash of type HASH-ALGO, return an
  219. s-expression suitable for use as the 'data' argument for 'sign'. KEY-TYPE
  220. must be a symbol: 'dsa, 'ecc, or 'rsa."
  221. (string->canonical-sexp
  222. (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
  223. (case key-type
  224. ((ecc dsa) "rfc6979")
  225. ((rsa) "pkcs1")
  226. (else (error "unknown key type" key-type)))
  227. hash-algo
  228. (bytevector->base16-string bv))))
  229. (define (key-type sexp)
  230. "Return a symbol denoting the type of public or private key represented by
  231. SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
  232. (case (canonical-sexp-nth-data sexp 0)
  233. ((public-key private-key)
  234. (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
  235. (else #f)))
  236. (define* (hash-data->bytevector data)
  237. "Return two values: the hash value (a bytevector), and the hash algorithm (a
  238. string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
  239. Return #f if DATA does not conform."
  240. (let ((hash (find-sexp-token data 'hash)))
  241. (if hash
  242. (let ((algo (canonical-sexp-nth-data hash 1))
  243. (value (canonical-sexp-nth-data hash 2)))
  244. (values value (symbol->string algo)))
  245. (values #f #f))))
  246. (define sign
  247. (let* ((ptr (libgcrypt-func "gcry_pk_sign"))
  248. (proc (pointer->procedure int ptr '(* * *))))
  249. (lambda (data secret-key)
  250. "Sign DATA, a canonical s-expression representing a suitable hash, with
  251. SECRET-KEY (a canonical s-expression whose car is 'private-key'.) Note that
  252. DATA must be a 'data' s-expression, as returned by
  253. 'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
  254. (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
  255. (err (proc sig (canonical-sexp->pointer data)
  256. (canonical-sexp->pointer secret-key))))
  257. (if (= 0 err)
  258. (pointer->canonical-sexp (dereference-pointer sig))
  259. (throw 'gcry-error 'sign err))))))
  260. (define verify
  261. (let* ((ptr (libgcrypt-func "gcry_pk_verify"))
  262. (proc (pointer->procedure int ptr '(* * *))))
  263. (lambda (signature data public-key)
  264. "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
  265. which are gcrypt s-expressions."
  266. (zero? (proc (canonical-sexp->pointer signature)
  267. (canonical-sexp->pointer data)
  268. (canonical-sexp->pointer public-key))))))
  269. (define generate-key
  270. (let* ((ptr (libgcrypt-func "gcry_pk_genkey"))
  271. (proc (pointer->procedure int ptr '(* *))))
  272. (lambda (params)
  273. "Return as an s-expression a new key pair for PARAMS. PARAMS must be an
  274. s-expression like: (genkey (rsa (nbits 4:2048)))."
  275. (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
  276. (err (proc key (canonical-sexp->pointer params))))
  277. (if (zero? err)
  278. (pointer->canonical-sexp (dereference-pointer key))
  279. (throw 'gcry-error 'generate-key err))))))
  280. (define find-sexp-token
  281. (let* ((ptr (libgcrypt-func "gcry_sexp_find_token"))
  282. (proc (pointer->procedure '* ptr `(* * ,size_t))))
  283. (lambda (sexp token)
  284. "Find in SEXP the first element whose 'car' is TOKEN and return it;
  285. return #f if not found."
  286. (let* ((token (string->pointer (symbol->string token)))
  287. (res (proc (canonical-sexp->pointer sexp) token 0)))
  288. (if (null-pointer? res)
  289. #f
  290. (pointer->canonical-sexp res))))))
  291. (define-inlinable (canonical-sexp-null? sexp)
  292. "Return #t if SEXP is the empty-list sexp."
  293. (null-pointer? (canonical-sexp->pointer sexp)))
  294. (define (canonical-sexp-list? sexp)
  295. "Return #t if SEXP is a list."
  296. (or (canonical-sexp-null? sexp)
  297. (> (canonical-sexp-length sexp) 0)))
  298. (define (canonical-sexp-fold proc seed sexp)
  299. "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp."
  300. (if (canonical-sexp-list? sexp)
  301. (let ((len (canonical-sexp-length sexp)))
  302. (let loop ((index 0)
  303. (result seed))
  304. (if (= index len)
  305. result
  306. (loop (+ 1 index)
  307. ;; XXX: Call 'nth-data' *before* 'nth' to work around
  308. ;; <https://bugs.g10code.com/gnupg/issue1594>, which
  309. ;; affects 1.6.0 and earlier versions.
  310. (proc (or (canonical-sexp-nth-data sexp index)
  311. (canonical-sexp-nth sexp index))
  312. result)))))
  313. (error "sexp is not a list" sexp)))
  314. (define (canonical-sexp->sexp sexp)
  315. "Return a Scheme sexp corresponding to SEXP. This is particularly useful to
  316. compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to
  317. use pattern matching."
  318. (if (canonical-sexp-list? sexp)
  319. (reverse
  320. (canonical-sexp-fold (lambda (item result)
  321. (cons (if (canonical-sexp? item)
  322. (canonical-sexp->sexp item)
  323. item)
  324. result))
  325. '()
  326. sexp))
  327. ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a
  328. ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer.
  329. (let ((sexp (string->canonical-sexp
  330. (string-append "(" (canonical-sexp->string sexp)
  331. ")"))))
  332. (or (canonical-sexp-nth-data sexp 0)
  333. (canonical-sexp-nth sexp 0)))))
  334. (define (sexp->canonical-sexp sexp)
  335. "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by
  336. 'canonical-sexp->sexp'."
  337. ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
  338. ;; much better.
  339. (string->canonical-sexp
  340. (call-with-output-string
  341. (lambda (port)
  342. (define (write item)
  343. (cond ((list? item)
  344. (display "(" port)
  345. (for-each write item)
  346. (display ")" port))
  347. ((symbol? item)
  348. (format port " ~a" item))
  349. ((bytevector? item)
  350. (format port " #~a#"
  351. (bytevector->base16-string item)))
  352. (else
  353. (error "unsupported sexp item type" item))))
  354. (write sexp)))))
  355. ;;; pk-crypto.scm ends here