aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/pk-crypto.scm66
-rw-r--r--tests/pk-crypto.scm46
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)