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