diff options
| -rw-r--r-- | guix/pk-crypto.scm | 114 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 18 | ||||
| -rw-r--r-- | tests/pk-crypto.scm | 46 |
3 files changed, 91 insertions, 87 deletions
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index d8fbb6f85b..1676abe642 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -24,14 +24,14 @@ #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (gcry-sexp? - string->gcry-sexp - gcry-sexp->string - number->gcry-sexp - gcry-sexp-car - gcry-sexp-cdr - gcry-sexp-nth - gcry-sexp-nth-data + #:export (canonical-sexp? + string->canonical-sexp + canonical-sexp->string + number->canonical-sexp + canonical-sexp-car + canonical-sexp-cdr + canonical-sexp-nth + canonical-sexp-nth-data bytevector->hash-data hash-data->bytevector sign @@ -44,24 +44,28 @@ ;;; ;;; Public key cryptographic routines from GNU Libgcrypt. ;;;; -;;; Libgcrypt uses s-expressions to represent key material, parameters, and -;;; data. We keep it as an opaque object rather than attempting to map them -;;; to Scheme s-expressions because (1) Libgcrypt sexps are stored in secure -;;; memory, and (2) the read syntax is different. +;;; Libgcrypt uses "canonical s-expressions" to represent key material, +;;; parameters, and data. We keep it as an opaque object rather than +;;; attempting to map them to Scheme s-expressions because (1) Libgcrypt sexps +;;; are stored in secure memory, and (2) the read syntax is different. +;;; +;;; Canonical sexps were defined by Rivest et al. in the IETF draft at +;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI +;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.) ;;; ;;; Code: ;; Libgcrypt "s-expressions". -(define-wrapped-pointer-type <gcry-sexp> - gcry-sexp? - naked-pointer->gcry-sexp - gcry-sexp->pointer +(define-wrapped-pointer-type <canonical-sexp> + canonical-sexp? + naked-pointer->canonical-sexp + canonical-sexp->pointer (lambda (obj port) ;; Don't print OBJ's external representation: we don't want key material ;; to leak in backtraces and such. - (format port "#<gcry-sexp ~a | ~a>" + (format port "#<canonical-sexp ~a | ~a>" (number->string (object-address obj) 16) - (number->string (pointer-address (gcry-sexp->pointer obj)) + (number->string (pointer-address (canonical-sexp->pointer obj)) 16)))) (define libgcrypt-func @@ -70,22 +74,22 @@ "Return a pointer to symbol FUNC in libgcrypt." (dynamic-func func lib)))) -(define finalize-gcry-sexp! +(define finalize-canonical-sexp! (libgcrypt-func "gcry_sexp_release")) -(define-inlinable (pointer->gcry-sexp ptr) - "Return a <gcry-sexp> that wraps PTR." - (let* ((sexp (naked-pointer->gcry-sexp ptr)) - (ptr* (gcry-sexp->pointer sexp))) - ;; Did we already have a <gcry-sexp> object for PTR? +(define-inlinable (pointer->canonical-sexp ptr) + "Return a <canonical-sexp> that wraps PTR." + (let* ((sexp (naked-pointer->canonical-sexp ptr)) + (ptr* (canonical-sexp->pointer sexp))) + ;; Did we already have a <canonical-sexp> object for PTR? (when (equal? ptr ptr*) ;; No, so we can safely add a finalizer (in Guile 2.0.9 ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the ;; existing one.) - (set-pointer-finalizer! ptr finalize-gcry-sexp!)) + (set-pointer-finalizer! ptr finalize-canonical-sexp!)) sexp)) -(define string->gcry-sexp +(define string->canonical-sexp (let* ((ptr (libgcrypt-func "gcry_sexp_new")) (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) (lambda (str) @@ -93,58 +97,58 @@ (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) (err (proc sexp (string->pointer str) 0 1))) (if (= 0 err) - (pointer->gcry-sexp (dereference-pointer sexp)) + (pointer->canonical-sexp (dereference-pointer sexp)) (throw 'gcry-error err)))))) (define-syntax GCRYSEXP_FMT_ADVANCED (identifier-syntax 3)) -(define gcry-sexp->string +(define canonical-sexp->string (let* ((ptr (libgcrypt-func "gcry_sexp_sprint")) (proc (pointer->procedure size_t ptr `(* ,int * ,size_t)))) (lambda (sexp) "Return a textual representation of SEXP." (let loop ((len 1024)) (let* ((buf (bytevector->pointer (make-bytevector len))) - (size (proc (gcry-sexp->pointer sexp) + (size (proc (canonical-sexp->pointer sexp) GCRYSEXP_FMT_ADVANCED buf len))) (if (zero? size) (loop (* len 2)) (pointer->string buf size "ISO-8859-1"))))))) -(define gcry-sexp-car +(define canonical-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)))) + (let ((result (proc (canonical-sexp->pointer lst)))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) -(define gcry-sexp-cdr +(define canonical-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)))) + (let ((result (proc (canonical-sexp->pointer lst)))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) -(define gcry-sexp-nth +(define canonical-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))) + (let ((result (proc (canonical-sexp->pointer lst) index))) (if (null-pointer? result) #f - (pointer->gcry-sexp result)))))) + (pointer->canonical-sexp result)))))) (define (dereference-size_t p) "Return the size_t value pointed to by P." @@ -152,7 +156,7 @@ different from Scheme's 'list-ref'.)" 0 (native-endianness) (sizeof size_t))) -(define gcry-sexp-nth-data +(define canonical-sexp-nth-data (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) (proc (pointer->procedure '* ptr `(* ,int *)))) (lambda (lst index) @@ -161,20 +165,20 @@ 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*))) + (result (proc (canonical-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) +(define (number->canonical-sexp number) "Return an s-expression representing NUMBER." - (string->gcry-sexp (string-append "#" (number->string number 16) "#"))) + (string->canonical-sexp (string-append "#" (number->string number 16) "#"))) (define* (bytevector->hash-data bv #:optional (hash-algo "sha256")) "Given BV, a bytevector containing a hash, return an s-expression suitable for use as the data for 'sign'." - (string->gcry-sexp + (string->canonical-sexp (format #f "(data (flags pkcs1) (hash \"~a\" #~a#))" hash-algo (bytevector->base16-string bv)))) @@ -192,8 +196,8 @@ 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))) + (let ((algo (canonical-sexp-nth-data hash 1)) + (value (canonical-sexp-nth-data hash 2))) (values (latin1-string->bytevector value) algo)) (values #f #f)))) @@ -205,10 +209,10 @@ Return #f if DATA does not conform." "Sign DATA (an s-expression) with SECRET-KEY (an s-expression whose car is 'private-key'.)" (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sig (gcry-sexp->pointer data) - (gcry-sexp->pointer secret-key)))) + (err (proc sig (canonical-sexp->pointer data) + (canonical-sexp->pointer secret-key)))) (if (= 0 err) - (pointer->gcry-sexp (dereference-pointer sig)) + (pointer->canonical-sexp (dereference-pointer sig)) (throw 'gry-error err)))))) (define verify @@ -217,9 +221,9 @@ is 'private-key'.)" (lambda (signature data public-key) "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of which are gcrypt s-expressions." - (zero? (proc (gcry-sexp->pointer signature) - (gcry-sexp->pointer data) - (gcry-sexp->pointer public-key)))))) + (zero? (proc (canonical-sexp->pointer signature) + (canonical-sexp->pointer data) + (canonical-sexp->pointer public-key)))))) (define generate-key (let* ((ptr (libgcrypt-func "gcry_pk_genkey")) @@ -228,9 +232,9 @@ which are gcrypt s-expressions." "Return as an s-expression a new key pair for PARAMS. PARAMS must be an s-expression like: (genkey (rsa (nbits 4:2048)))." (let* ((key (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc key (gcry-sexp->pointer params)))) + (err (proc key (canonical-sexp->pointer params)))) (if (zero? err) - (pointer->gcry-sexp (dereference-pointer key)) + (pointer->canonical-sexp (dereference-pointer key)) (throw 'gcry-error err)))))) (define find-sexp-token @@ -240,9 +244,9 @@ s-expression like: (genkey (rsa (nbits 4:2048)))." "Find in SEXP the first element whose 'car' is TOKEN and return it; return #f if not found." (let* ((token (string->pointer (symbol->string token))) - (res (proc (gcry-sexp->pointer sexp) token 0))) + (res (proc (canonical-sexp->pointer sexp) token 0))) (if (null-pointer? res) #f - (pointer->gcry-sexp res)))))) + (pointer->canonical-sexp res)))))) ;;; pk-crypto.scm ends here diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index cbafed79d0..70ba7cb88e 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -33,10 +33,10 @@ ;;; ;;; Code: -(define (read-gcry-sexp file) +(define (read-canonical-sexp file) "Read a gcrypt sexp from FILE and return it." (call-with-input-file file - (compose string->gcry-sexp get-string-all))) + (compose string->canonical-sexp get-string-all))) (define (read-hash-data file) "Read sha256 hash data from FILE and return it as a gcrypt sexp." @@ -56,18 +56,18 @@ (("rsautl" "-sign" "-inkey" key "-in" hash-file) ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes ;; both the hash and the actual signature. - (let* ((secret-key (read-gcry-sexp key)) + (let* ((secret-key (read-canonical-sexp key)) (data (read-hash-data hash-file))) (format #t "(guix-signature ~a (payload ~a))" - (gcry-sexp->string (sign data secret-key)) - (gcry-sexp->string data)) + (canonical-sexp->string (sign data secret-key)) + (canonical-sexp->string data)) #t)) (("rsautl" "-verify" "-inkey" key "-pubin" "-in" signature-file) ;; Read the signature as produced above, check it against KEY, and print ;; the signed data to stdout upon success. - (let* ((public-key (read-gcry-sexp key)) - (sig+data (read-gcry-sexp signature-file)) + (let* ((public-key (read-canonical-sexp key)) + (sig+data (read-canonical-sexp signature-file)) (data (find-sexp-token sig+data 'payload)) (signature (find-sexp-token sig+data 'sig-val))) (if (and data signature) @@ -79,12 +79,12 @@ (begin (format (current-error-port) "error: invalid signature: ~a~%" - (gcry-sexp->string signature)) + (canonical-sexp->string signature)) (exit 1))) (begin (format (current-error-port) "error: corrupt signature data: ~a~%" - (gcry-sexp->string sig+data)) + (canonical-sexp->string sig+data)) (exit 1))))) (("--help") (display (_ "Usage: guix authenticate OPTION... diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index eddd5c4945..85f8f9407e 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -32,7 +32,7 @@ (define %key-pair ;; Key pair that was generated with: - ;; (generate-key (string->gcry-sexp "(genkey (rsa (nbits 4:1024)))")) + ;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))")) ;; which takes a bit of time. "(key-data (public-key @@ -57,11 +57,11 @@ ;;"#C0FFEE#" "(genkey \n (rsa \n (nbits \"1024\")\n )\n )"))) - (test-equal "string->gcry-sexp->string" + (test-equal "string->canonical-sexp->string" sexps - (let ((sexps (map string->gcry-sexp sexps))) - (and (every gcry-sexp? sexps) - (map (compose string-trim-both gcry-sexp->string) sexps))))) + (let ((sexps (map string->canonical-sexp sexps))) + (and (every canonical-sexp? sexps) + (map (compose string-trim-both canonical-sexp->string) sexps))))) (gc) ; stress test! @@ -75,43 +75,43 @@ sexps) (map (match-lambda ((input token '-> _) - (let ((sexp (find-sexp-token (string->gcry-sexp input) token))) + (let ((sexp (find-sexp-token (string->canonical-sexp input) token))) (and sexp - (string-trim-both (gcry-sexp->string sexp)))))) + (string-trim-both (canonical-sexp->string sexp)))))) sexps))) (gc) -(test-equal "gcry-sexp-car + cdr" +(test-equal "canonical-sexp-car + cdr" '("(b \n (c xyz)\n )") - (let ((lst (string->gcry-sexp "(a (b (c xyz)))"))) + (let ((lst (string->canonical-sexp "(a (b (c xyz)))"))) (map (lambda (sexp) - (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (and sexp (string-trim-both (canonical-sexp->string sexp)))) ;; Note: 'car' returns #f when the first element is an atom. - (list (gcry-sexp-car (gcry-sexp-cdr lst)))))) + (list (canonical-sexp-car (canonical-sexp-cdr lst)))))) (gc) -(test-equal "gcry-sexp-nth" +(test-equal "canonical-sexp-nth" '("(b pqr)" "(c \"456\")" "(d xyz)" #f #f) - (let ((lst (string->gcry-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) - ;; XXX: In Libgcrypt 1.5.3, (gcry-sexp-nth lst 0) returns LST, whereas in + (let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) + ;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in ;; 1.6.0 it returns #f. (map (lambda (sexp) - (and sexp (string-trim-both (gcry-sexp->string sexp)))) + (and sexp (string-trim-both (canonical-sexp->string sexp)))) (unfold (cut > <> 5) - (cut gcry-sexp-nth lst <>) + (cut canonical-sexp-nth lst <>) 1+ 1)))) (gc) -(test-equal "gcry-sexp-nth-data" +(test-equal "canonical-sexp-nth-data" '("Name" "Otto" "Meier" #f #f #f) - (let ((lst (string->gcry-sexp "(Name Otto Meier (address Burgplatz))"))) + (let ((lst (string->canonical-sexp "(Name Otto Meier (address Burgplatz))"))) (unfold (cut > <> 5) - (cut gcry-sexp-nth-data lst <>) + (cut canonical-sexp-nth-data lst <>) 1+ 0))) @@ -120,9 +120,9 @@ ;; XXX: The test below is typically too long as it needs to gather enough entropy. ;; (test-assert "generate-key" -;; (let ((key (generate-key (string->gcry-sexp +;; (let ((key (generate-key (string->canonical-sexp ;; "(genkey (rsa (nbits 3:128)))")))) -;; (and (gcry-sexp? key) +;; (and (canonical-sexp? key) ;; (find-sexp-token key 'key-data) ;; (find-sexp-token key 'public-key) ;; (find-sexp-token key 'private-key)))) @@ -130,13 +130,13 @@ (test-assert "bytevector->hash-data->bytevector" (let* ((bv (sha256 (string->utf8 "Hello, world."))) (data (bytevector->hash-data bv "sha256"))) - (and (gcry-sexp? data) + (and (canonical-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)) + (let* ((pair (string->canonical-sexp %key-pair)) (secret (find-sexp-token pair 'private-key)) (public (find-sexp-token pair 'public-key)) (data (bytevector->hash-data |