kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

pki: Add 'signature-case' macro.

Browse Source 
* guix/pki.scm (%signature-status): New procedure.
  (signature-case): New macro.
* tests/pki.scm (%secret-key, %alternate-secret-key): New variables.
  ("signature-case valid-signature", "signature-case invalid-signature",
  "signature-case hash-mismatch", "signature-case unauthorized-key",
  "signature-case corrupt-signature"): New tests.
This commit is contained in:
Ludovic Courtès 2014-03-31 23:34:20 +02:00
parent 8146fdb334
commit 81deef270d
3 changed files with 139 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.dir-locals.el
View File

@ -8,6 +8,7 @@
((indent-tabs-mode . nil)
(eval . (put 'test-assert 'scheme-indent-function 1))
(eval . (put 'test-equal 'scheme-indent-function 1))
(eval . (put 'test-eq 'scheme-indent-function 1))
(eval . (put 'call-with-input-string 'scheme-indent-function 1))
(eval . (put 'guard 'scheme-indent-function 1))
(eval . (put 'lambda* 'scheme-indent-function 1))
@ -24,6 +25,7 @@
(eval . (put 'with-atomic-file-output 'scheme-indent-function 1))
(eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2))
(eval . (put 'call-with-decompressed-port 'scheme-indent-function 2))
(eval . (put 'signature-case 'scheme-indent-function 1))
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))
(eval . (put 'with-monad 'scheme-indent-function 1))

62
guix/pki.scm
View File

@ -34,7 +34,8 @@
signature-sexp
signature-subject
signature-signed-data
valid-signature?))
valid-signature?
signature-case))
;;; Commentary:
;;;
@ -157,4 +158,63 @@ PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
(and data signature
(verify signature data public-key))))
(define* (%signature-status signature hash
#:optional (acl (current-acl)))
"Return a symbol denoting the status of SIGNATURE vs. HASH vs. ACL.
This procedure must only be used internally, because it would be easy to
forget some of the cases."
(let ((subject (signature-subject signature))
(data (signature-signed-data signature)))
(if (and data subject)
(if (authorized-key? subject acl)
(if (equal? (hash-data->bytevector data) hash)
(if (valid-signature? signature)
'valid-signature
'invalid-signature)
'hash-mismatch)
'unauthorized-key)
'corrupt-signature)))
(define-syntax signature-case
(syntax-rules (valid-signature invalid-signature
hash-mismatch unauthorized-key corrupt-signature
else)
"\
Match the cases of the verification of SIGNATURE against HASH and ACL:
- the 'valid-signature' case if SIGNATURE is indeed a signature of HASH with
a key present in ACL;
- 'invalid-signature' if SIGNATURE is incorrect;
- 'hash-mismatch' if the hash in SIGNATURE does not match HASH;
- 'unauthorized-key' if the public key in SIGNATURE is not listed in ACL;
- 'corrupt-signature' if SIGNATURE is not a valid signature sexp.
This macro guarantees at compile-time that all these cases are handled.
SIGNATURE, and ACL must be canonical sexps; HASH must be a bytevector."
;; Simple case: we only care about valid signatures.
((_ (signature hash acl)
(valid-signature valid-exp ...)
(else else-exp ...))
(case (%signature-status signature hash acl)
((valid-signature) valid-exp ...)
(else else-exp ...)))
;; Full case.
((_ (signature hash acl)
(valid-signature valid-exp ...)
(invalid-signature invalid-exp ...)
(hash-mismatch mismatch-exp ...)
(unauthorized-key unauthorized-exp ...)
(corrupt-signature corrupt-exp ...))
(case (%signature-status signature hash acl)
((valid-signature) valid-exp ...)
((invalid-signature) invalid-exp ...)
((hash-mismatch) mismatch-exp ...)
((unauthorized-key) unauthorized-exp ...)
((corrupt-signature) corrupt-exp ...)
(else (error "bogus signature status"))))))
;;; pki.scm ends here

79
tests/pki.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -19,6 +19,7 @@
(define-module (test-pki)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
#:use-module (guix hash)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-64))
@ -26,8 +27,28 @@
(define %public-key
(call-with-input-file %public-key-file
(compose string->canonical-sexp
get-string-all)))
(compose string->canonical-sexp get-string-all)))
(define %secret-key
(call-with-input-file %private-key-file
(compose string->canonical-sexp get-string-all)))
(define %alternate-secret-key
(string->canonical-sexp
"
(key-data
(public-key
(rsa
(n #00FDBF170366AC43B7D95CF9085565C566FB1F21B17C0A36E68F35ABB500E7851E00B40D7B04C8CD25903371F38E4C298FACEFFC4C97E913B536A0672BAF99D04515AE98A1A56627CD7EB02502FCFBEEA21AF13CC1A853192AD6409B9EFBD9F549BDE32BD890AE01F9A221E81FEE1C407090550647790E0D60775B855E181C2FB5#)
(e #010001#)))
(private-key
(rsa
(n #00FDBF170366AC43B7D95CF9085565C566FB1F21B17C0A36E68F35ABB500E7851E00B40D7B04C8CD25903371F38E4C298FACEFFC4C97E913B536A0672BAF99D04515AE98A1A56627CD7EB02502FCFBEEA21AF13CC1A853192AD6409B9EFBD9F549BDE32BD890AE01F9A221E81FEE1C407090550647790E0D60775B855E181C2FB5#)
(e #010001#)
(d #2790250C2E74C2FD361A99288BBA19B878048F5A0F333F829CC71B3DD64582DB9DF3F4DB1EB0994DD7493225EDA4A1E1492F44D903617FA5643E47BFC7BA157EF48B492AB51229916B02DDBDA0E7DBC7B35A6B8332AB463DC61951CA694551A9760F5A836A375D39E3EA8F2C502A3B5D89CB8777A809B75D603BE7511CEB74E9#)
(p #00FE15B1751E1C31125B724FF37462F9476239A2AFF4192FAB1550F76928C8D02407F4F5EFC83F7A0AF51BD93399DDC06A4B54DFA60A7079F160A9F618C0148AD9#)
(q #00FFA8BE7005AAB7401B0926CD9D6AC30BC9BE7D12C8737C9438498A999F56BE9F5EA98B4D7F5364BEB6D550A5AEDDE34C1EC152C9DAF61A97FDE71740C73BAA3D#)
(u #00FD4050EF4F31B41EC81C28E18D205DFFB3C188F15D8BBA300E30AD8B5C4D3E392EFE10269FC115A538B19F4025973AB09B6650A7FF97DA833FB726F3D8819319#))))"))
(test-begin "pki")
@ -45,6 +66,58 @@
(test-assert "authorized-key? public-key singleton"
(authorized-key? %public-key (public-keys->acl (list %public-key))))
(test-assert "signature-case valid-signature"
(let* ((hash (sha256 #vu8(1 2 3)))
(data (bytevector->hash-data hash #:key-type (key-type %public-key)))
(sig (signature-sexp data %secret-key %public-key)))
(signature-case (sig hash (public-keys->acl (list %public-key)))
(valid-signature #t)
(else #f))))
(test-eq "signature-case invalid-signature" 'i
(let* ((hash (sha256 #vu8(1 2 3)))
(data (bytevector->hash-data hash #:key-type (key-type %public-key)))
(sig (signature-sexp data %alternate-secret-key %public-key)))
(signature-case (sig hash (public-keys->acl (list %public-key)))
(valid-signature 'v)
(invalid-signature 'i)
(hash-mismatch 'm)
(unauthorized-key 'u)
(corrupt-signature 'c))))
(test-eq "signature-case hash-mismatch" 'm
(let* ((hash (sha256 #vu8(1 2 3)))
(data (bytevector->hash-data hash #:key-type (key-type %public-key)))
(sig (signature-sexp data %secret-key %public-key)))
(signature-case (sig (sha256 #vu8())
(public-keys->acl (list %public-key)))
(valid-signature 'v)
(invalid-signature 'i)
(hash-mismatch 'm)
(unauthorized-key 'u)
(corrupt-signature 'c))))
(test-eq "signature-case unauthorized-key" 'u
(let* ((hash (sha256 #vu8(1 2 3)))
(data (bytevector->hash-data hash #:key-type (key-type %public-key)))
(sig (signature-sexp data %secret-key %public-key)))
(signature-case (sig hash (public-keys->acl '()))
(valid-signature 'v)
(invalid-signature 'i)
(hash-mismatch 'm)
(unauthorized-key 'u)
(corrupt-signature 'c))))
(test-eq "signature-case corrupt-signature" 'c
(let* ((hash (sha256 #vu8(1 2 3)))
(sig (string->canonical-sexp "(w tf)")))
(signature-case (sig hash (public-keys->acl (list %public-key)))
(valid-signature 'v)
(invalid-signature 'i)
(hash-mismatch 'm)
(unauthorized-key 'u)
(corrupt-signature 'c))))
(test-end)