aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-12-20 15:22:15 +0100
committerLudovic Courtès <ludo@gnu.org>2013-12-20 15:22:15 +0100
commitce507041f79bd66f54ce406d20b9e33a328a3f3d (patch)
treecf19d2a4e7b5a04c335eadf92503eb7ba1eede7e
parent971cb56dd0c1a1cb265d2adfe41730cd2f8c5c22 (diff)
downloadguix-ce507041f79bd66f54ce406d20b9e33a328a3f3d.tar
guix-ce507041f79bd66f54ce406d20b9e33a328a3f3d.tar.gz
pk-crypto: Add a few sexp utility procedures.
* guix/pk-crypto.scm (gcry-sexp-car, gcry-sexp-cdr, gcry-sexp-nth, gcry-sexp-nth-data, dereference-size_t, latin1-string->bytevector, hash-data->bytevector): New procedures. * tests/pk-crypto.scm ("gcry-sexp-car + cdr", "gcry-sexp-nth", "gcry-sexp-nth-data", "bytevector->hash-data->bytevector"): New tests.
-rw-r--r--guix/pk-crypto.scm83
-rw-r--r--tests/pk-crypto.scm42
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))