From 9501d7745eca2c6c5b18f7b573c08398c3ffa4d8 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 28 Dec 2013 16:16:00 +0100
Subject: pk-crypto: Add canonical-sexp to sexp conversion procedures.

* guix/pk-crypto.scm (canonical-sexp-fold, canonical-sexp->sexp,
  sexp->canonical-sexp): New procedures.
* tests/pk-crypto.scm ("canonical-sexp->sexp",
  "sexp->canonical-sexp->sexp"): New tests.
---
 guix/pk-crypto.scm  | 66 +++++++++++++++++++++++++++++++++++++++++++++++++----
 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)
 
 
-- 
cgit 1.4.1