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.
master
Ludovic Courtès
parent
971cb56dd0
commit
ce507041f7
|
|
@ -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 '(* * *))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue