diff options
| -rw-r--r-- | guix/pk-crypto.scm | 83 | ||||
| -rw-r--r-- | tests/pk-crypto.scm | 42 |
2 files changed, 124 insertions, 1 deletions
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 9d093b34b0..d8fbb6f85b 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -18,7 +18,9 @@ (define-module (guix pk-crypto) #:use-module (guix config) - #:use-module ((guix utils) #:select (bytevector->base16-string)) + #:use-module ((guix utils) + #:select (bytevector->base16-string + base16-string->bytevector)) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -26,7 +28,12 @@ string->gcry-sexp gcry-sexp->string number->gcry-sexp + gcry-sexp-car + gcry-sexp-cdr + gcry-sexp-nth + gcry-sexp-nth-data bytevector->hash-data + hash-data->bytevector sign verify generate-key @@ -105,6 +112,61 @@ (loop (* len 2)) (pointer->string buf size "ISO-8859-1"))))))) +(define gcry-sexp-car + (let* ((ptr (libgcrypt-func "gcry_sexp_car")) + (proc (pointer->procedure '* ptr '(*)))) + (lambda (lst) + "Return the first element of LST, an sexp, if that element is a list; +return #f if LST or its first element is not a list (this is different from +the usual Lisp 'car'.)" + (let ((result (proc (gcry-sexp->pointer lst)))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define gcry-sexp-cdr + (let* ((ptr (libgcrypt-func "gcry_sexp_cdr")) + (proc (pointer->procedure '* ptr '(*)))) + (lambda (lst) + "Return the tail of LST, an sexp, or #f if LST is not a list." + (let ((result (proc (gcry-sexp->pointer lst)))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define gcry-sexp-nth + (let* ((ptr (libgcrypt-func "gcry_sexp_nth")) + (proc (pointer->procedure '* ptr `(* ,int)))) + (lambda (lst index) + "Return the INDEXth nested element of LST, an s-expression. Return #f +if that element does not exist, or if it's an atom. (Note: this is obviously +different from Scheme's 'list-ref'.)" + (let ((result (proc (gcry-sexp->pointer lst) index))) + (if (null-pointer? result) + #f + (pointer->gcry-sexp result)))))) + +(define (dereference-size_t p) + "Return the size_t value pointed to by P." + (bytevector-uint-ref (pointer->bytevector p (sizeof size_t)) + 0 (native-endianness) + (sizeof size_t))) + +(define gcry-sexp-nth-data + (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) + (proc (pointer->procedure '* ptr `(* ,int *)))) + (lambda (lst index) + "Return as a string the INDEXth data element (atom) of LST, an +s-expression. Return #f if that element does not exist, or if it's a list. +Note that the result is a Scheme string, but depending on LST, it may need to +be interpreted in the sense of a C string---i.e., as a series of octets." + (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*)))) + (result (proc (gcry-sexp->pointer lst) index size*))) + (if (null-pointer? result) + #f + (pointer->string result (dereference-size_t size*) + "ISO-8859-1")))))) + (define (number->gcry-sexp number) "Return an s-expression representing NUMBER." (string->gcry-sexp (string-append "#" (number->string number 16) "#"))) @@ -117,6 +179,25 @@ for use as the data for 'sign'." hash-algo (bytevector->base16-string bv)))) +(define (latin1-string->bytevector str) + "Return a bytevector representing STR." + ;; XXX: In Guile 2.0.9 and later, we would use 'string->bytevector' for + ;; that. + (let ((bytes (map char->integer (string->list str)))) + (u8-list->bytevector bytes))) + +(define (hash-data->bytevector data) + "Return two values: the hash algorithm (a string) and the hash value (a +bytevector) extract from DATA, an sexp as returned by 'bytevector->hash-data'. +Return #f if DATA does not conform." + (let ((hash (find-sexp-token data 'hash))) + (if hash + (let ((algo (gcry-sexp-nth-data hash 1)) + (value (gcry-sexp-nth-data hash 2))) + (values (latin1-string->bytevector value) + algo)) + (values #f #f)))) + (define sign (let* ((ptr (libgcrypt-func "gcry_pk_sign")) (proc (pointer->procedure int ptr '(* * *)))) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 1acce13f0a..7c54e729ad 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -21,6 +21,8 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) @@ -75,6 +77,38 @@ (gc) +(test-equal "gcry-sexp-car + cdr" + '("(b \n (c xyz)\n )") + (let ((lst (string->gcry-sexp "(a (b (c xyz)))"))) + (map (lambda (sexp) + (and sexp (string-trim-both (gcry-sexp->string sexp)))) + ;; Note: 'car' returns #f when the first element is an atom. + (list (gcry-sexp-car (gcry-sexp-cdr lst)))))) + +(gc) + +(test-equal "gcry-sexp-nth" + '(#f "(b pqr)" "(c \"456\")" "(d xyz)" #f #f) + (let ((lst (string->gcry-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) + (map (lambda (sexp) + (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (unfold (cut > <> 5) + (cut gcry-sexp-nth lst <>) + 1+ + 0)))) + +(gc) + +(test-equal "gcry-sexp-nth-data" + '("Name" "Otto" "Meier" #f #f #f) + (let ((lst (string->gcry-sexp "(Name Otto Meier (address Burgplatz))"))) + (unfold (cut > <> 5) + (cut gcry-sexp-nth-data lst <>) + 1+ + 0))) + +(gc) + ;; XXX: The test below is typically too long as it needs to gather enough entropy. ;; (test-assert "generate-key" @@ -85,6 +119,14 @@ ;; (find-sexp-token key 'public-key) ;; (find-sexp-token key 'private-key)))) +(test-assert "bytevector->hash-data->bytevector" + (let* ((bv (sha256 (string->utf8 "Hello, world."))) + (data (bytevector->hash-data bv "sha256"))) + (and (gcry-sexp? data) + (let-values (((value algo) (hash-data->bytevector data))) + (and (string=? algo "sha256") + (bytevector=? value bv)))))) + (test-assert "sign + verify" (let* ((pair (string->gcry-sexp %key-pair)) (secret (find-sexp-token pair 'private-key)) |