[jackhill/guix/guix.git] / tests / substitute-binary.scm

;;; 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 (ice-9 regex)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #: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 bv #:key (public-key %public-key))
  "Return the signature of BV as the base64-encoded body of a narinfo's
'Signature' field."
  (base64-encode
   (string->utf8
    (canonical-sexp->string
     (signature-sexp (bytevector->hash-data (sha256 bv)
                                            #:key-type 'rsa)
                     %private-key
                     public-key)))))

(define %wrong-public-key
  (string->canonical-sexp "(public-key
 (rsa
  (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  (e #010001#)
  )
 )"))

(define* (signature-field bv-or-str
                          #:key (version "1") (public-key %public-key))
  "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
PUBLIC-KEY as the signature's principal, and using VERSION as the signature
version identifier.."
  (string-append version ";example.gnu.org;"
                 (signature-body (if (string? bv-or-str)
                                     (string->utf8 bv-or-str)
                                     bv-or-str)
                                 #:public-key public-key)))


\f
(test-begin "substitute-binary")

(test-error* "not a number"
  (narinfo-signature->canonical-sexp
   (signature-field "foo" #:version "not a number")))

(test-error* "wrong version number"
  (narinfo-signature->canonical-sexp
   (signature-field "foo" #:version "2")))

(test-assert "valid narinfo-signature->canonical-sexp"
  (canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))

(define-syntax-rule (test-error-condition name pred message-rx exp)
  (test-assert name
    (guard (condition ((pred condition)
                       (and (string-match message-rx
                                          (condition-message condition))
                            #t))
                      (else #f))
      exp
      #f)))

(test-error-condition "corrupt signature data"
    nar-signature-error? "corrupt"
  (assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
                          (open-input-string "irrelevant")
                          (public-keys->acl (list %public-key))))

(test-error-condition "unauthorized public key"
    nar-signature-error? "unauthorized"
  (assert-valid-signature (narinfo-signature->canonical-sexp
                           (signature-field "foo"))
                          "irrelevant"
                          (open-input-string "irrelevant")
                          (public-keys->acl '())))

(test-error-condition "invalid signature"
    nar-signature-error? "invalid signature"
  (let ((message "this is the message that we sign"))
    (assert-valid-signature (narinfo-signature->canonical-sexp
                             (signature-field message
                                              #:public-key %wrong-public-key))
                            (sha256 (string->utf8 message))
                            (open-input-string "irrelevant")
                            (public-keys->acl (list %wrong-public-key)))))

\f
(define %narinfo
  ;; Skeleton of the narinfo used below.
  (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 (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 in the signature differs from the hash of %NARINFO.
  ""

  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field "different body")
                               "\n")
    (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 (string-append %narinfo "Signature: "
                               (signature-field %narinfo)
                               "\n")
    (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 (string-append %narinfo "Signature: "
                               (signature-field
                                %narinfo
                                #:public-key %wrong-public-key)
                               "\n")
    (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 in the signature differs from the hash of %NARINFO.
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field "different body")
                               "\n")
    (guix-substitute-binary "--substitute"
                            (string-append (%store-prefix)
                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                            "foo")))

(test-error* "substitute, unauthorized key"
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field
                                %narinfo
                                #:public-key %wrong-public-key)
                               "\n")
    (guix-substitute-binary "--substitute"
                            (string-append (%store-prefix)
                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                            "foo")))

(test-end "substitute-binary")

\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))

;;; Local Variables:
;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
;;; eval: (put 'test-error-condition 'scheme-indent-function 3)
;;; eval: (put 'test-error* 'scheme-indent-function 1)
;;; End:
Commit	Line	Data
e9c6c584 NK	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
	3	;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (test-substitute-binary)
	21	#:use-module (guix scripts substitute-binary)
	22	#:use-module (guix base64)
	23	#:use-module (guix hash)
	24	#:use-module (guix nar)
	25	#:use-module (guix pk-crypto)
	26	#:use-module (guix pki)
cdea30e0 LC	27	#:use-module (guix config)
	28	#:use-module ((guix store) #:select (%store-prefix))
	29	#:use-module ((guix build utils) #:select (delete-file-recursively))
e9c6c584	30	#:use-module (rnrs bytevectors)
cdea30e0 LC	31	#:use-module (rnrs io ports)
cdea30e0 LC	32	#:use-module (web uri)
52f80dfc	33	#:use-module (ice-9 regex)
cdea30e0	34	#:use-module (srfi srfi-26)
e9c6c584	35	#:use-module (srfi srfi-34)
52f80dfc	36	#:use-module (srfi srfi-35)
e9c6c584 NK	37	#:use-module ((srfi srfi-64) #:hide (test-error)))
	38
	39	(define assert-valid-signature
	40	;; (guix scripts substitute-binary) does not export this function in order to
	41	;; avoid misuse.
	42	(@@ (guix scripts substitute-binary) assert-valid-signature))
	43
	44	;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to
	45	;;; catch specific exceptions.
	46	(define-syntax-rule (test-error* name exp)
cdea30e0 LC	47	(test-equal name
cdea30e0 LC	48	1
e9c6c584 NK	49	(catch 'quit
	50	(lambda ()
	51	exp
	52	#f)
cdea30e0 LC	53	(lambda (key value)
cdea30e0 LC	54	value))))
e9c6c584 NK	55
e9c6c584 NK	56	(define %public-key
cdea30e0 LC	57	;; This key is known to be in the ACL by default.
	58	(call-with-input-file (string-append %config-directory "/signing-key.pub")
	59	(compose string->canonical-sexp get-string-all)))
e9c6c584 NK	60
e9c6c584 NK	61	(define %private-key
cdea30e0 LC	62	(call-with-input-file (string-append %config-directory "/signing-key.sec")
cdea30e0 LC	63	(compose string->canonical-sexp get-string-all)))
e9c6c584	64
52f80dfc LC	65	(define* (signature-body bv #:key (public-key %public-key))
52f80dfc LC	66	"Return the signature of BV as the base64-encoded body of a narinfo's
cdea30e0	67	'Signature' field."
e9c6c584 NK	68	(base64-encode
	69	(string->utf8
	70	(canonical-sexp->string
52f80dfc	71	(signature-sexp (bytevector->hash-data (sha256 bv)
e9c6c584 NK	72	#:key-type 'rsa)
e9c6c584 NK	73	%private-key
cdea30e0	74	public-key)))))
e9c6c584	75
e9c6c584 NK	76	(define %wrong-public-key
	77	(string->canonical-sexp "(public-key
	78	(rsa
	79	(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
	80	(e #010001#)
	81	)
	82	)"))
	83
52f80dfc LC	84	(define* (signature-field bv-or-str
	85	#:key (version "1") (public-key %public-key))
	86	"Return the 'Signature' field value of bytevector/string BV-OR-STR, using
	87	PUBLIC-KEY as the signature's principal, and using VERSION as the signature
	88	version identifier.."
	89	(string-append version ";example.gnu.org;"
	90	(signature-body (if (string? bv-or-str)
	91	(string->utf8 bv-or-str)
	92	bv-or-str)
	93	#:public-key public-key)))
	94
e9c6c584	95
cdea30e0	96	\f
e9c6c584 NK	97	(test-begin "substitute-binary")
	98
	99	(test-error* "not a number"
52f80dfc LC	100	(narinfo-signature->canonical-sexp
52f80dfc LC	101	(signature-field "foo" #:version "not a number")))
e9c6c584 NK	102
e9c6c584 NK	103	(test-error* "wrong version number"
52f80dfc LC	104	(narinfo-signature->canonical-sexp
52f80dfc LC	105	(signature-field "foo" #:version "2")))
e9c6c584 NK	106
e9c6c584 NK	107	(test-assert "valid narinfo-signature->canonical-sexp"
52f80dfc	108	(canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
e9c6c584	109
52f80dfc	110	(define-syntax-rule (test-error-condition name pred message-rx exp)
e9c6c584	111	(test-assert name
52f80dfc LC	112	(guard (condition ((pred condition)
	113	(and (string-match message-rx
	114	(condition-message condition))
	115	#t))
e9c6c584 NK	116	(else #f))
	117	exp
	118	#f)))
	119
e9c6c584	120	(test-error-condition "corrupt signature data"
52f80dfc	121	nar-signature-error? "corrupt"
cdea30e0	122	(assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
e9c6c584	123	(open-input-string "irrelevant")
52f80dfc	124	(public-keys->acl (list %public-key))))
e9c6c584 NK	125
e9c6c584 NK	126	(test-error-condition "unauthorized public key"
52f80dfc LC	127	nar-signature-error? "unauthorized"
	128	(assert-valid-signature (narinfo-signature->canonical-sexp
	129	(signature-field "foo"))
e9c6c584 NK	130	"irrelevant"
	131	(open-input-string "irrelevant")
	132	(public-keys->acl '())))
	133
	134	(test-error-condition "invalid signature"
52f80dfc LC	135	nar-signature-error? "invalid signature"
	136	(let ((message "this is the message that we sign"))
	137	(assert-valid-signature (narinfo-signature->canonical-sexp
	138	(signature-field message
	139	#:public-key %wrong-public-key))
	140	(sha256 (string->utf8 message))
	141	(open-input-string "irrelevant")
	142	(public-keys->acl (list %wrong-public-key)))))
e9c6c584	143
cdea30e0	144	\f
e9c6c584	145	(define %narinfo
52f80dfc	146	;; Skeleton of the narinfo used below.
cdea30e0 LC	147	(string-append "StorePath: " (%store-prefix)
cdea30e0 LC	148	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
e9c6c584 NK	149	URL: nar/foo
	150	Compression: bzip2
	151	NarHash: sha256:7
	152	NarSize: 42
	153	References: bar baz
cdea30e0 LC	154	Deriver: " (%store-prefix) "/foo.drv
cdea30e0 LC	155	System: mips64el-linux\n"))
e9c6c584	156
cdea30e0 LC	157	(define (call-with-narinfo narinfo thunk)
	158	"Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
	159	a file for NARINFO."
	160	(let ((narinfo-directory (and=> (string->uri (getenv
	161	"GUIX_BINARY_SUBSTITUTE_URL"))
	162	uri-path))
	163	(cache-directory (string-append (getenv "XDG_CACHE_HOME")
	164	"/guix/substitute-binary/")))
	165	(dynamic-wind
	166	(lambda ()
	167	(when (file-exists? cache-directory)
	168	(delete-file-recursively cache-directory))
	169	(call-with-output-file (string-append narinfo-directory
	170	"/nix-cache-info")
	171	(lambda (port)
	172	(format port "StoreDir: ~a\nWantMassQuery: 0\n"
	173	(%store-prefix))))
	174	(call-with-output-file (string-append narinfo-directory "/"
	175	"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
	176	".narinfo")
	177	(cut display narinfo <>))
	178
	179	(set! (@@ (guix scripts substitute-binary)
	180	%allow-unauthenticated-substitutes?)
	181	#f))
	182	thunk
	183	(lambda ()
	184	(delete-file-recursively cache-directory)))))
	185
	186	(define-syntax-rule (with-narinfo narinfo body ...)
	187	(call-with-narinfo narinfo (lambda () body ...)))
	188
	189
	190	(test-equal "query narinfo with invalid hash"
52f80dfc	191	;; The hash in the signature differs from the hash of %NARINFO.
cdea30e0 LC	192	""
cdea30e0 LC	193
52f80dfc LC	194	(with-narinfo (string-append %narinfo "Signature: "
	195	(signature-field "different body")
	196	"\n")
cdea30e0 LC	197	(string-trim-both
	198	(with-output-to-string
	199	(lambda ()
	200	(with-input-from-string (string-append "have " (%store-prefix)
	201	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	202	(lambda ()
	203	(guix-substitute-binary "--query"))))))))
	204
	205	(test-equal "query narinfo signed with authorized key"
	206	(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	207
52f80dfc LC	208	(with-narinfo (string-append %narinfo "Signature: "
	209	(signature-field %narinfo)
	210	"\n")
cdea30e0 LC	211	(string-trim-both
	212	(with-output-to-string
	213	(lambda ()
	214	(with-input-from-string (string-append "have " (%store-prefix)
	215	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	216	(lambda ()
	217	(guix-substitute-binary "--query"))))))))
	218
	219	(test-equal "query narinfo signed with unauthorized key"
	220	"" ; not substitutable
	221
52f80dfc LC	222	(with-narinfo (string-append %narinfo "Signature: "
	223	(signature-field
	224	%narinfo
	225	#:public-key %wrong-public-key)
	226	"\n")
cdea30e0 LC	227	(string-trim-both
	228	(with-output-to-string
	229	(lambda ()
	230	(with-input-from-string (string-append "have " (%store-prefix)
	231	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	232	(lambda ()
	233	(guix-substitute-binary "--query"))))))))
	234
	235	(test-error* "substitute, invalid hash"
52f80dfc LC	236	;; The hash in the signature differs from the hash of %NARINFO.
	237	(with-narinfo (string-append %narinfo "Signature: "
	238	(signature-field "different body")
	239	"\n")
cdea30e0 LC	240	(guix-substitute-binary "--substitute"
	241	(string-append (%store-prefix)
	242	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	243	"foo")))
	244
	245	(test-error* "substitute, unauthorized key"
52f80dfc LC	246	(with-narinfo (string-append %narinfo "Signature: "
	247	(signature-field
	248	%narinfo
	249	#:public-key %wrong-public-key)
	250	"\n")
cdea30e0 LC	251	(guix-substitute-binary "--substitute"
	252	(string-append (%store-prefix)
	253	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	254	"foo")))
e9c6c584 NK	255
	256	(test-end "substitute-binary")
	257
	258	\f
	259	(exit (= (test-runner-fail-count (test-runner-current)) 0))
cdea30e0 LC	260
	261	;;; Local Variables:
	262	;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
52f80dfc	263	;;; eval: (put 'test-error-condition 'scheme-indent-function 3)
cdea30e0 LC	264	;;; eval: (put 'test-error* 'scheme-indent-function 1)
cdea30e0 LC	265	;;; End: