;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix pki)
#:use-module (guix config)
- #:use-module (guix pk-crypto)
+ #:use-module (gcrypt pk-crypto)
#:use-module ((guix utils) #:select (with-atomic-file-output))
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 match)
- #:use-module (rnrs io ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 binary-ports)
#:export (%public-key-file
%private-key-file
%acl-file
current-acl
public-keys->acl
acl->public-keys
+ authorized-key?
+ write-acl
+
signature-sexp
- authorized-key?))
+ signature-subject
+ signature-signed-data
+ valid-signature?
+ signature-case))
;;; Commentary:
;;;
;;;
;;; Code:
-(define (acl-entry-sexp public-key)
- "Return a SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
-signed by the corresponding secret key (see the IETF draft at
-<http://theworld.com/~cme/spki.txt> for the ACL format.)"
- ;; Note: We always use PUBLIC-KEY to designate the subject. Someday we may
- ;; want to have name certificates and to use subject names instead of
- ;; complete keys.
- (string->canonical-sexp
- (format #f
- "(entry ~a (tag (guix import)))"
- (canonical-sexp->string public-key))))
-
-(define (acl-sexp entries)
- "Return an ACL sexp from ENTRIES, a list of 'entry' sexps."
- (string->canonical-sexp
- (string-append "(acl "
- (string-join (map canonical-sexp->string entries))
- ")")))
-
(define (public-keys->acl keys)
- "Return an ACL canonical sexp that lists all of KEYS with a '(guix import)'
+ "Return an ACL that lists all of KEYS with a '(guix import)'
tag---meaning that all of KEYS are authorized for archive imports. Each
element in KEYS must be a canonical sexp with type 'public-key'."
- (acl-sexp (map acl-entry-sexp keys)))
+
+ ;; Use SPKI-style ACL entry sexp for PUBLIC-KEY, authorizing imports
+ ;; signed by the corresponding secret key (see the IETF draft at
+ ;; <http://theworld.com/~cme/spki.txt> for the ACL format.)
+ ;;
+ ;; Note: We always use PUBLIC-KEY to designate the subject. Someday we may
+ ;; want to have name certificates and to use subject names instead of
+ ;; complete keys.
+ `(acl ,@(map (lambda (key)
+ `(entry ,(canonical-sexp->sexp key)
+ (tag (guix import))))
+ keys)))
(define %acl-file
(string-append %config-directory "/acl"))
(when (file-exists? %public-key-file)
(let ((public-key (call-with-input-file %public-key-file
(compose string->canonical-sexp
- get-string-all))))
+ read-string))))
(mkdir-p (dirname %acl-file))
(with-atomic-file-output %acl-file
(lambda (port)
- (display (canonical-sexp->string
- (public-keys->acl (list public-key)))
- port)))))))
+ (write-acl (public-keys->acl (list public-key))
+ port)))))))
+
+(define (write-acl acl port)
+ "Write ACL to PORT in canonical-sexp format."
+ (let ((sexp (sexp->canonical-sexp acl)))
+ (display (canonical-sexp->string sexp) port)))
(define (current-acl)
- "Return the current ACL as a canonical sexp."
+ "Return the current ACL."
(ensure-acl)
(if (file-exists? %acl-file)
(call-with-input-file %acl-file
- (compose string->canonical-sexp
- get-string-all))
+ (compose canonical-sexp->sexp
+ string->canonical-sexp
+ read-string))
(public-keys->acl '()))) ; the empty ACL
(define (acl->public-keys acl)
"Return the public keys (as canonical sexps) listed in ACL with the '(guix
import)' tag."
- (match (canonical-sexp->sexp acl)
+ (match acl
(('acl
('entry subject-keys
('tag ('guix 'import)))
(_
(error "invalid access-control list" acl))))
-(define* (authorized-key? key
- #:optional (acl (current-acl)))
+(define* (authorized-key? key #:optional (acl (current-acl)))
"Return #t if KEY (a canonical sexp) is an authorized public key for archive
imports according to ACL."
+ ;; Note: ACL is kept in native sexp form to make 'authorized-key?' faster,
+ ;; by not having to convert it with 'canonical-sexp->sexp' on each call.
+ ;; TODO: We could use a better data type for ACLs.
(let ((key (canonical-sexp->sexp key)))
- (match (canonical-sexp->sexp acl)
+ (match acl
(('acl
('entry subject-keys
('tag ('guix 'import)))
(canonical-sexp->string (sign data secret-key))
(canonical-sexp->string public-key))))
+(define (signature-subject sig)
+ "Return the signer's public key for SIG."
+ (find-sexp-token sig 'public-key))
+
+(define (signature-signed-data sig)
+ "Return the signed data from SIG, typically an sexp such as
+ (hash \"sha256\" #...#)."
+ (find-sexp-token sig 'data))
+
+(define (valid-signature? sig)
+ "Return #t if SIG is valid."
+ (let* ((data (signature-signed-data sig))
+ (signature (find-sexp-token sig 'sig-val))
+ (public-key (signature-subject sig)))
+ (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
HCoop / jackhill / guix / guix.git / blobdiff