pk-crypto.scm 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2013, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
  4. ;;;
  5. ;;; This file is part of guile-gcrypt.
  6. ;;;
  7. ;;; guile-gcrypt 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
  10. ;;; (at your option) any later version.
  11. ;;;
  12. ;;; guile-gcrypt 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 GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (gcrypt pk-crypto)
  20. #:use-module (gcrypt base16)
  21. #:use-module (gcrypt internal)
  22. #:use-module (gcrypt common)
  23. #:use-module (system foreign)
  24. #:use-module (rnrs bytevectors)
  25. #:use-module (ice-9 match)
  26. #:use-module (ice-9 rdelim)
  27. #:export (canonical-sexp?
  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->pointer "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 ((proc (libgcrypt->procedure int
  94. "gcry_sexp_new"
  95. `(* * ,size_t ,int))))
  96. (lambda (str)
  97. "Parse STR and return the corresponding gcrypt s-expression."
  98. ;; When STR comes from 'canonical-sexp->string', it may contain
  99. ;; characters that are really meant to be interpreted as bytes as in a C
  100. ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the
  101. ;; characters are preserved.
  102. (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*))))
  103. (err (proc sexp (string->pointer str "ISO-8859-1") 0 1)))
  104. (if (= 0 err)
  105. (pointer->canonical-sexp (dereference-pointer sexp))
  106. (throw 'gcry-error 'string->canonical-sexp err))))))
  107. (define-syntax GCRYSEXP_FMT_ADVANCED
  108. (identifier-syntax 3))
  109. (define canonical-sexp->string
  110. (let ((proc (libgcrypt->procedure size_t
  111. "gcry_sexp_sprint"
  112. `(* ,int * ,size_t))))
  113. (lambda (sexp)
  114. "Return a textual representation of SEXP."
  115. (let loop ((len 1024))
  116. (let* ((buf (bytevector->pointer (make-bytevector len)))
  117. (size (proc (canonical-sexp->pointer sexp)
  118. GCRYSEXP_FMT_ADVANCED buf len)))
  119. (if (zero? size)
  120. (loop (* len 2))
  121. (pointer->string buf size "ISO-8859-1")))))))
  122. (define (read-file-sexp file)
  123. "Return the canonical sexp read from FILE."
  124. (call-with-input-file file
  125. (compose string->canonical-sexp
  126. read-string)))
  127. (define canonical-sexp-car
  128. (let ((proc (libgcrypt->procedure '* "gcry_sexp_car" '(*))))
  129. (lambda (lst)
  130. "Return the first element of LST, an sexp, if that element is a list;
  131. return #f if LST or its first element is not a list (this is different from
  132. the usual Lisp 'car'.)"
  133. (let ((result (proc (canonical-sexp->pointer lst))))
  134. (if (null-pointer? result)
  135. #f
  136. (pointer->canonical-sexp result))))))
  137. (define canonical-sexp-cdr
  138. (let ((proc (libgcrypt->procedure '* "gcry_sexp_cdr" '(*))))
  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 ((proc (libgcrypt->procedure '* "gcry_sexp_nth" `(* ,int))))
  147. (lambda (lst index)
  148. "Return the INDEXth nested element of LST, an s-expression. Return #f
  149. if that element does not exist, or if it's an atom. (Note: this is obviously
  150. different from Scheme's 'list-ref'.)"
  151. (let ((result (proc (canonical-sexp->pointer lst) index)))
  152. (if (null-pointer? result)
  153. #f
  154. (pointer->canonical-sexp result))))))
  155. (define (dereference-size_t p)
  156. "Return the size_t value pointed to by P."
  157. (bytevector-uint-ref (pointer->bytevector p (sizeof size_t))
  158. 0 (native-endianness)
  159. (sizeof size_t)))
  160. (define canonical-sexp-length
  161. (let ((proc (libgcrypt->procedure int "gcry_sexp_length" '(*))))
  162. (lambda (sexp)
  163. "Return the length of SEXP if it's a list (including the empty list);
  164. return zero if SEXP is an atom."
  165. (proc (canonical-sexp->pointer sexp)))))
  166. (define token-string?
  167. (let ((token-cs (char-set-union char-set:digit
  168. char-set:letter
  169. (char-set #\- #\. #\/ #\_
  170. #\: #\* #\+ #\=))))
  171. (lambda (str)
  172. "Return #t if STR is a token as per Section 4.3 of
  173. <http://people.csail.mit.edu/rivest/Sexp.txt>."
  174. (and (not (string-null? str))
  175. (string-every token-cs str)
  176. (not (char-set-contains? char-set:digit (string-ref str 0)))))))
  177. (define canonical-sexp-nth-data
  178. (let ((proc (libgcrypt->procedure '* "gcry_sexp_nth_data" `(* ,int *))))
  179. (lambda (lst index)
  180. "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other
  181. \"octet string\") the INDEXth data element (atom) of LST, an s-expression.
  182. Return #f if that element does not exist, or if it's a list."
  183. (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*))))
  184. (result (proc (canonical-sexp->pointer lst) index size*)))
  185. (if (null-pointer? result)
  186. #f
  187. (let* ((len (dereference-size_t size*))
  188. (str (pointer->string result len "ISO-8859-1")))
  189. ;; The sexp spec speaks of "tokens" and "octet strings".
  190. ;; Sometimes these octet strings are actual strings (text),
  191. ;; sometimes they're bytevectors, and sometimes they're
  192. ;; multi-precision integers (MPIs). Only the application knows.
  193. ;; However, for convenience, we return a symbol when a token is
  194. ;; encountered since tokens are frequent (at least in the 'car'
  195. ;; of each sexp.)
  196. (if (token-string? str)
  197. (string->symbol str) ; an sexp "token"
  198. (bytevector-copy ; application data, textual or binary
  199. (pointer->bytevector result len)))))))))
  200. (define (number->canonical-sexp number)
  201. "Return an s-expression representing NUMBER."
  202. (let ((hex-number
  203. (match (number->string number 16)
  204. ;; Append a 0 if necessary. For whatever reason gcrypt
  205. ;; rejects hex numbers that don't have an even number of
  206. ;; digits.
  207. ((? (lambda (s) (odd? (string-length s))) odd-string)
  208. (string-append "0" odd-string))
  209. (even-str even-str))))
  210. (string->canonical-sexp (string-append "#" hex-number "#"))))
  211. (define* (bytevector->hash-data bv
  212. #:optional
  213. (hash-algo "sha256")
  214. #:key (key-type 'ecc))
  215. "Given BV, a bytevector containing a hash of type HASH-ALGO, return an
  216. s-expression suitable for use as the 'data' argument for 'sign'. KEY-TYPE
  217. must be a symbol: 'dsa, 'ecc, or 'rsa."
  218. (string->canonical-sexp
  219. (format #f "(data (flags ~a) (hash \"~a\" #~a#))"
  220. (case key-type
  221. ((ecc dsa) "rfc6979")
  222. ((rsa) "pkcs1")
  223. (else (error "unknown key type" key-type)))
  224. hash-algo
  225. (bytevector->base16-string bv))))
  226. (define (key-type sexp)
  227. "Return a symbol denoting the type of public or private key represented by
  228. SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key."
  229. (case (canonical-sexp-nth-data sexp 0)
  230. ((public-key private-key)
  231. (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0))
  232. (else #f)))
  233. (define* (hash-data->bytevector data)
  234. "Return two values: the hash value (a bytevector), and the hash algorithm (a
  235. string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'.
  236. Return #f if DATA does not conform."
  237. (let ((hash (find-sexp-token data 'hash)))
  238. (if hash
  239. (let ((algo (canonical-sexp-nth-data hash 1))
  240. (value (canonical-sexp-nth-data hash 2)))
  241. (values value (symbol->string algo)))
  242. (values #f #f))))
  243. (define sign
  244. (let ((proc (libgcrypt->procedure int "gcry_pk_sign" '(* * *))))
  245. (lambda (data secret-key)
  246. "Sign DATA, a canonical s-expression representing a suitable hash, with
  247. SECRET-KEY (a canonical s-expression whose car is 'private-key'.) Note that
  248. DATA must be a 'data' s-expression, as returned by
  249. 'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")."
  250. (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*))))
  251. (err (proc sig (canonical-sexp->pointer data)
  252. (canonical-sexp->pointer secret-key))))
  253. (if (= 0 err)
  254. (pointer->canonical-sexp (dereference-pointer sig))
  255. (throw 'gcry-error 'sign err))))))
  256. (define verify
  257. (let ((proc (libgcrypt->procedure int "gcry_pk_verify" '(* * *))))
  258. (lambda (signature data public-key)
  259. "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of
  260. which are gcrypt s-expressions; return #t if the verification was successful,
  261. #f otherwise. Raise an error if, for example, one of the given s-expressions
  262. is invalid."
  263. (let ((err (proc (canonical-sexp->pointer signature)
  264. (canonical-sexp->pointer data)
  265. (canonical-sexp->pointer public-key))))
  266. (cond ((zero? err) #t)
  267. ((error-code=? error/bad-signature err) #f)
  268. (else (throw 'gcry-error 'verify err)))))))
  269. (define generate-key
  270. (let ((proc (libgcrypt->procedure int "gcry_pk_genkey" '(* *))))
  271. (lambda (params)
  272. "Return as an s-expression a new key pair for PARAMS. PARAMS must be an
  273. s-expression like: (genkey (rsa (nbits 4:2048)))."
  274. (let* ((key (bytevector->pointer (make-bytevector (sizeof '*))))
  275. (err (proc key (canonical-sexp->pointer params))))
  276. (if (zero? err)
  277. (pointer->canonical-sexp (dereference-pointer key))
  278. (throw 'gcry-error 'generate-key err))))))
  279. (define find-sexp-token
  280. (let ((proc (libgcrypt->procedure '*
  281. "gcry_sexp_find_token"
  282. `(* * ,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://dev.gnupg.org/T1594>, 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. (define (string-hex-pad str)
  338. (if (odd? (string-length str))
  339. (string-append "0" str)
  340. str))
  341. ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do
  342. ;; much better.
  343. (string->canonical-sexp
  344. (call-with-output-string
  345. (lambda (port)
  346. (define (write item)
  347. (cond ((list? item)
  348. (display "(" port)
  349. (for-each write item)
  350. (display ")" port))
  351. ((symbol? item)
  352. (format port " ~a" item))
  353. ((bytevector? item)
  354. (format port " #~a#"
  355. (bytevector->base16-string item)))
  356. ((integer? item)
  357. (format port " #~a#"
  358. (string-hex-pad (number->string item 16))))
  359. (else
  360. (error "unsupported sexp item type" item))))
  361. (write sexp)))))
  362. ;;; pk-crypto.scm ends here