diff options
| -rw-r--r-- | guix/pk-crypto.scm | 66 | ||||
| -rw-r--r-- | tests/pk-crypto.scm | 46 |
2 files changed, 108 insertions, 4 deletions
diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index 0d1af07313..0e7affcce8 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -40,7 +40,9 @@ sign verify generate-key - find-sexp-token)) + find-sexp-token + canonical-sexp->sexp + sexp->canonical-sexp)) ;;; Commentary: @@ -48,9 +50,13 @@ ;;; Public key cryptographic routines from GNU Libgcrypt. ;;;; ;;; 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. +;;; parameters, and data. We keep it as an opaque object to map them to +;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure +;;; memory, and (2) the read syntax is different. +;;; +;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in +;;; cases where it is safe to move data out of Libgcrypt---e.g., when +;;; processing ACL entries, public keys, etc. ;;; ;;; 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 @@ -283,4 +289,56 @@ return #f if not found." (or (canonical-sexp-null? sexp) (> (canonical-sexp-length sexp) 0))) +(define (canonical-sexp-fold proc seed sexp) + "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp." + (if (canonical-sexp-list? sexp) + (let ((len (canonical-sexp-length sexp))) + (let loop ((index 0) + (result seed)) + (if (= index len) + result + (loop (+ 1 index) + (proc (or (canonical-sexp-nth sexp index) + (canonical-sexp-nth-data sexp index)) + result))))) + (error "sexp is not a list" sexp))) + +(define (canonical-sexp->sexp sexp) + "Return a Scheme sexp corresponding to SEXP. This is particularly useful to +compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to +use pattern matching." + (if (canonical-sexp-list? sexp) + (reverse + (canonical-sexp-fold (lambda (item result) + (cons (if (canonical-sexp? item) + (canonical-sexp->sexp item) + item) + result)) + '() + sexp)) + (canonical-sexp->string sexp))) ; XXX: not very useful + +(define (sexp->canonical-sexp sexp) + "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by +'canonical-sexp->sexp'." + ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do + ;; much better. + (string->canonical-sexp + (call-with-output-string + (lambda (port) + (define (write item) + (cond ((list? item) + (display "(" port) + (for-each write item) + (display ")" port)) + ((symbol? item) + (format port " ~a" item)) + ((bytevector? item) + (format port " #~a#" + (bytevector->base16-string item))) + (else + (error "unsupported sexp item type" item)))) + + (write sexp))))) + ;;; pk-crypto.scm ends here diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 3135d5a60c..a894a60531 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -163,6 +163,52 @@ (gc) +(test-equal "canonical-sexp->sexp" + `((data + (flags pkcs1) + (hash sha256 + ,(base16-string->bytevector + "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) + + (public-key + (rsa + (n ,(base16-string->bytevector + (string-downcase + "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) + (e ,(base16-string->bytevector + "010001"))))) + + (list (canonical-sexp->sexp + (string->canonical-sexp + "(data + (flags pkcs1) + (hash \"sha256\" + #2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))")) + + (canonical-sexp->sexp + (find-sexp-token (string->canonical-sexp %key-pair) + 'public-key)))) + + +(let ((lst + `((data + (flags pkcs1) + (hash sha256 + ,(base16-string->bytevector + "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) + + (public-key + (rsa + (n ,(base16-string->bytevector + (string-downcase + "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) + (e ,(base16-string->bytevector + "010001"))))))) + (test-equal "sexp->canonical-sexp->sexp" + lst + (map (compose canonical-sexp->sexp sexp->canonical-sexp) + lst))) + (test-end) |