cdea30e061
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
274 lines
10 KiB
Scheme
274 lines
10 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
|
||
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (test-substitute-binary)
|
||
#:use-module (guix scripts substitute-binary)
|
||
#:use-module (guix base64)
|
||
#:use-module (guix hash)
|
||
#:use-module (guix nar)
|
||
#:use-module (guix pk-crypto)
|
||
#:use-module (guix pki)
|
||
#:use-module (guix config)
|
||
#:use-module ((guix store) #:select (%store-prefix))
|
||
#:use-module ((guix build utils) #:select (delete-file-recursively))
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (rnrs io ports)
|
||
#:use-module (web uri)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-34)
|
||
#:use-module ((srfi srfi-64) #:hide (test-error)))
|
||
|
||
(define assert-valid-signature
|
||
;; (guix scripts substitute-binary) does not export this function in order to
|
||
;; avoid misuse.
|
||
(@@ (guix scripts substitute-binary) assert-valid-signature))
|
||
|
||
;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to
|
||
;;; catch specific exceptions.
|
||
(define-syntax-rule (test-error* name exp)
|
||
(test-equal name
|
||
1
|
||
(catch 'quit
|
||
(lambda ()
|
||
exp
|
||
#f)
|
||
(lambda (key value)
|
||
value))))
|
||
|
||
(define %public-key
|
||
;; This key is known to be in the ACL by default.
|
||
(call-with-input-file (string-append %config-directory "/signing-key.pub")
|
||
(compose string->canonical-sexp get-string-all)))
|
||
|
||
(define %private-key
|
||
(call-with-input-file (string-append %config-directory "/signing-key.sec")
|
||
(compose string->canonical-sexp get-string-all)))
|
||
|
||
(define* (signature-body str #:key (public-key %public-key))
|
||
"Return the signature of STR as the base64-encoded body of a narinfo's
|
||
'Signature' field."
|
||
(base64-encode
|
||
(string->utf8
|
||
(canonical-sexp->string
|
||
(signature-sexp (bytevector->hash-data (sha256 (string->utf8 str))
|
||
#:key-type 'rsa)
|
||
%private-key
|
||
public-key)))))
|
||
|
||
(define %signature-body
|
||
;; Body of the signature of the word "secret".
|
||
(signature-body "secret"))
|
||
|
||
(define %wrong-public-key
|
||
(string->canonical-sexp "(public-key
|
||
(rsa
|
||
(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
|
||
(e #010001#)
|
||
)
|
||
)"))
|
||
|
||
(define %wrong-signature
|
||
;; 'Signature' field where the public key doesn't match the private key used
|
||
;; to make the signature.
|
||
(let* ((body (string->canonical-sexp
|
||
(utf8->string
|
||
(base64-decode %signature-body))))
|
||
(data (canonical-sexp->string (find-sexp-token body 'data)))
|
||
(sig-val (canonical-sexp->string (find-sexp-token body 'sig-val)))
|
||
(public-key (canonical-sexp->string %wrong-public-key))
|
||
(body* (base64-encode
|
||
(string->utf8
|
||
(string-append "(signature \n" data sig-val
|
||
public-key " )\n")))))
|
||
(string-append "1;irrelevant;" body*)))
|
||
|
||
(define* (signature str #:optional (body %signature-body))
|
||
"Return the 'Signature' field value with STR as the version part and BODY as
|
||
the actual base64-encoded signature part."
|
||
(string-append str ";irrelevant;" body))
|
||
|
||
(define %signature
|
||
;; Signature computed over the word "secret".
|
||
(signature "1" %signature-body))
|
||
|
||
(define %acl
|
||
(public-keys->acl (list %public-key)))
|
||
|
||
|
||
(test-begin "substitute-binary")
|
||
|
||
(test-error* "not a number"
|
||
(narinfo-signature->canonical-sexp (signature "not a number")))
|
||
|
||
(test-error* "wrong version number"
|
||
(narinfo-signature->canonical-sexp (signature "2")))
|
||
|
||
(test-assert "valid narinfo-signature->canonical-sexp"
|
||
(canonical-sexp? (narinfo-signature->canonical-sexp %signature)))
|
||
|
||
(define-syntax-rule (test-error-condition name pred exp)
|
||
(test-assert name
|
||
(guard (condition ((pred condition) #t)
|
||
(else #f))
|
||
exp
|
||
#f)))
|
||
|
||
;;; XXX: Do we need a better predicate hierarchy for these tests?
|
||
(test-error-condition "corrupt signature data"
|
||
nar-signature-error?
|
||
(assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
|
||
(open-input-string "irrelevant")
|
||
%acl))
|
||
|
||
(test-error-condition "unauthorized public key"
|
||
nar-signature-error?
|
||
(assert-valid-signature (narinfo-signature->canonical-sexp %signature)
|
||
"irrelevant"
|
||
(open-input-string "irrelevant")
|
||
(public-keys->acl '())))
|
||
|
||
(test-error-condition "invalid signature"
|
||
nar-signature-error?
|
||
(assert-valid-signature (narinfo-signature->canonical-sexp
|
||
%wrong-signature)
|
||
(sha256 (string->utf8 "secret"))
|
||
(open-input-string "irrelevant")
|
||
(public-keys->acl (list %wrong-public-key))))
|
||
|
||
|
||
(define %narinfo
|
||
(string-append "StorePath: " (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
|
||
URL: nar/foo
|
||
Compression: bzip2
|
||
NarHash: sha256:7
|
||
NarSize: 42
|
||
References: bar baz
|
||
Deriver: " (%store-prefix) "/foo.drv
|
||
System: mips64el-linux\n"))
|
||
|
||
(define (narinfo sig)
|
||
"Return a narinfo with SIG as its 'Signature' field."
|
||
(format #f "~aSignature: ~a~%" %narinfo sig))
|
||
|
||
(define %signed-narinfo
|
||
;; Narinfo with a valid signature.
|
||
(narinfo (signature "1" (signature-body %narinfo))))
|
||
|
||
(define (call-with-narinfo narinfo thunk)
|
||
"Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
|
||
a file for NARINFO."
|
||
(let ((narinfo-directory (and=> (string->uri (getenv
|
||
"GUIX_BINARY_SUBSTITUTE_URL"))
|
||
uri-path))
|
||
(cache-directory (string-append (getenv "XDG_CACHE_HOME")
|
||
"/guix/substitute-binary/")))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(when (file-exists? cache-directory)
|
||
(delete-file-recursively cache-directory))
|
||
(call-with-output-file (string-append narinfo-directory
|
||
"/nix-cache-info")
|
||
(lambda (port)
|
||
(format port "StoreDir: ~a\nWantMassQuery: 0\n"
|
||
(%store-prefix))))
|
||
(call-with-output-file (string-append narinfo-directory "/"
|
||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||
".narinfo")
|
||
(cut display narinfo <>))
|
||
|
||
(set! (@@ (guix scripts substitute-binary)
|
||
%allow-unauthenticated-substitutes?)
|
||
#f))
|
||
thunk
|
||
(lambda ()
|
||
(delete-file-recursively cache-directory)))))
|
||
|
||
(define-syntax-rule (with-narinfo narinfo body ...)
|
||
(call-with-narinfo narinfo (lambda () body ...)))
|
||
|
||
|
||
(test-equal "query narinfo with invalid hash"
|
||
;; The hash of '%signature' is computed over the word "secret", not
|
||
;; '%narinfo'.
|
||
""
|
||
|
||
(with-narinfo (narinfo %signature)
|
||
(string-trim-both
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(with-input-from-string (string-append "have " (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
(lambda ()
|
||
(guix-substitute-binary "--query"))))))))
|
||
|
||
(test-equal "query narinfo signed with authorized key"
|
||
(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
|
||
(with-narinfo %signed-narinfo
|
||
(string-trim-both
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(with-input-from-string (string-append "have " (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
(lambda ()
|
||
(guix-substitute-binary "--query"))))))))
|
||
|
||
(test-equal "query narinfo signed with unauthorized key"
|
||
"" ; not substitutable
|
||
|
||
(with-narinfo (narinfo (signature "1"
|
||
(signature-body %narinfo
|
||
#:public-key %wrong-public-key)))
|
||
(string-trim-both
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(with-input-from-string (string-append "have " (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
(lambda ()
|
||
(guix-substitute-binary "--query"))))))))
|
||
|
||
(test-error* "substitute, invalid hash"
|
||
;; The hash of '%signature' is computed over the word "secret", not
|
||
;; '%narinfo'.
|
||
(with-narinfo (narinfo %signature)
|
||
(guix-substitute-binary "--substitute"
|
||
(string-append (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
"foo")))
|
||
|
||
(test-error* "substitute, unauthorized key"
|
||
(with-narinfo (narinfo (signature "1"
|
||
(signature-body %narinfo
|
||
#:public-key %wrong-public-key)))
|
||
(guix-substitute-binary "--substitute"
|
||
(string-append (%store-prefix)
|
||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||
"foo")))
|
||
|
||
(test-end "substitute-binary")
|
||
|
||
|
||
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|
||
|
||
;;; Local Variables:
|
||
;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
|
||
;;; eval: (put 'test-error* 'scheme-indent-function 1)
|
||
;;; End:
|