mirror of git://git.savannah.gnu.org/guix.git
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.
This commit is contained in:
Ludovic Courtès
parent
363ae1da82
commit
9501d7745e
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue