[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 base32)
  #:use-module ((guix store) #:select (%store-prefix))
  #:use-module ((guix ui) #:select (guix-warning-port))
  #: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-syntax-rule (test-quit name error-rx exp)
  "Emit a test that passes when EXP throws to 'quit' with value 1, and when
it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  (test-equal name
    '(1 #t)
    (let ((error-output (open-output-string)))
      (parameterize ((guix-warning-port error-output))
        (catch 'quit
          (lambda ()
            exp
            #f)
          (lambda (key value)
            (list value
                  (let ((message (get-output-string error-output)))
                    (->bool (string-match error-rx message))))))))))

(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-quit "not a number"
    "signature version"
  (narinfo-signature->canonical-sexp
   (signature-field "foo" #:version "not a number")))

(test-quit "wrong version number"
    "unsupported.*version"
  (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"))))


\f
(define %narinfo
  ;; Skeleton of the narinfo used below.
  (string-append "StorePath: " (%store-prefix)
                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
URL: example.nar
Compression: none
NarHash: sha256:" (bytevector->nix-base32-string
                   (sha256 (string->utf8 "Substitutable data."))) "
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 <>))

        ;; Prepare the nar.
        (call-with-output-file
            (string-append narinfo-directory "/example.out")
          (cut display "Substitutable data." <>))
        (call-with-output-file
            (string-append narinfo-directory "/example.nar")
          (cute write-file
                (string-append narinfo-directory "/example.out") <>))

        (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 ...)))

;; Transmit these options to 'guix substitute-binary'.
(set! (@@ (guix scripts substitute-binary) %cache-url)
      (getenv "GUIX_BINARY_SUBSTITUTE_URL"))

(test-equal "query narinfo without signature"
  ""                                              ; not substitutable

  (with-narinfo %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 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-quit "substitute, no signature"
    "lacks a signature"
  (with-narinfo %narinfo
    (guix-substitute-binary "--substitute"
                            (string-append (%store-prefix)
                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                            "foo")))

(test-quit "substitute, invalid hash"
    "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-quit "substitute, unauthorized key"
    "unauthorized"
  (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-equal "substitute, authorized key"
  "Substitutable data."
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field %narinfo))
    (dynamic-wind
      (const #t)
      (lambda ()
        (guix-substitute-binary "--substitute"
                                (string-append (%store-prefix)
                                               "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                                "substitute-retrieved")
        (call-with-input-file "substitute-retrieved" get-string-all))
      (lambda ()
        (false-if-exception (delete-file "substitute-retrieved"))))))

(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-quit 'scheme-indent-function 2)
;;; 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	27	#:use-module (guix config)
e903b7c1	28	#:use-module (guix base32)
cdea30e0	29	#:use-module ((guix store) #:select (%store-prefix))
f84f8590	30	#:use-module ((guix ui) #:select (guix-warning-port))
cdea30e0	31	#:use-module ((guix build utils) #:select (delete-file-recursively))
e9c6c584	32	#:use-module (rnrs bytevectors)
cdea30e0 LC	33	#:use-module (rnrs io ports)
cdea30e0 LC	34	#:use-module (web uri)
52f80dfc	35	#:use-module (ice-9 regex)
cdea30e0	36	#:use-module (srfi srfi-26)
e9c6c584	37	#:use-module (srfi srfi-34)
52f80dfc	38	#:use-module (srfi srfi-35)
e9c6c584 NK	39	#:use-module ((srfi srfi-64) #:hide (test-error)))
e9c6c584 NK	40
f84f8590 LC	41	(define-syntax-rule (test-quit name error-rx exp)
	42	"Emit a test that passes when EXP throws to 'quit' with value 1, and when
	43	it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
cdea30e0	44	(test-equal name
f84f8590 LC	45	'(1 #t)
	46	(let ((error-output (open-output-string)))
	47	(parameterize ((guix-warning-port error-output))
	48	(catch 'quit
	49	(lambda ()
	50	exp
	51	#f)
	52	(lambda (key value)
	53	(list value
	54	(let ((message (get-output-string error-output)))
	55	(->bool (string-match error-rx message))))))))))
e9c6c584 NK	56
e9c6c584 NK	57	(define %public-key
cdea30e0 LC	58	;; This key is known to be in the ACL by default.
	59	(call-with-input-file (string-append %config-directory "/signing-key.pub")
	60	(compose string->canonical-sexp get-string-all)))
e9c6c584 NK	61
e9c6c584 NK	62	(define %private-key
cdea30e0 LC	63	(call-with-input-file (string-append %config-directory "/signing-key.sec")
cdea30e0 LC	64	(compose string->canonical-sexp get-string-all)))
e9c6c584	65
52f80dfc LC	66	(define* (signature-body bv #:key (public-key %public-key))
52f80dfc LC	67	"Return the signature of BV as the base64-encoded body of a narinfo's
cdea30e0	68	'Signature' field."
e9c6c584 NK	69	(base64-encode
	70	(string->utf8
	71	(canonical-sexp->string
52f80dfc	72	(signature-sexp (bytevector->hash-data (sha256 bv)
e9c6c584 NK	73	#:key-type 'rsa)
e9c6c584 NK	74	%private-key
cdea30e0	75	public-key)))))
e9c6c584	76
e9c6c584 NK	77	(define %wrong-public-key
	78	(string->canonical-sexp "(public-key
	79	(rsa
	80	(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
	81	(e #010001#)
	82	)
	83	)"))
	84
52f80dfc LC	85	(define* (signature-field bv-or-str
	86	#:key (version "1") (public-key %public-key))
	87	"Return the 'Signature' field value of bytevector/string BV-OR-STR, using
	88	PUBLIC-KEY as the signature's principal, and using VERSION as the signature
	89	version identifier.."
	90	(string-append version ";example.gnu.org;"
	91	(signature-body (if (string? bv-or-str)
	92	(string->utf8 bv-or-str)
	93	bv-or-str)
	94	#:public-key public-key)))
	95
e9c6c584	96
cdea30e0	97	\f
e9c6c584 NK	98	(test-begin "substitute-binary")
e9c6c584 NK	99
f84f8590 LC	100	(test-quit "not a number"
f84f8590 LC	101	"signature version"
52f80dfc LC	102	(narinfo-signature->canonical-sexp
52f80dfc LC	103	(signature-field "foo" #:version "not a number")))
e9c6c584	104
f84f8590 LC	105	(test-quit "wrong version number"
f84f8590 LC	106	"unsupported.*version"
52f80dfc LC	107	(narinfo-signature->canonical-sexp
52f80dfc LC	108	(signature-field "foo" #:version "2")))
e9c6c584 NK	109
e9c6c584 NK	110	(test-assert "valid narinfo-signature->canonical-sexp"
52f80dfc	111	(canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
e9c6c584	112
e9c6c584	113
cdea30e0	114	\f
e9c6c584	115	(define %narinfo
52f80dfc	116	;; Skeleton of the narinfo used below.
cdea30e0 LC	117	(string-append "StorePath: " (%store-prefix)
cdea30e0 LC	118	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
e903b7c1 LC	119	URL: example.nar
	120	Compression: none
	121	NarHash: sha256:" (bytevector->nix-base32-string
	122	(sha256 (string->utf8 "Substitutable data."))) "
e9c6c584 NK	123	NarSize: 42
e9c6c584 NK	124	References: bar baz
cdea30e0 LC	125	Deriver: " (%store-prefix) "/foo.drv
cdea30e0 LC	126	System: mips64el-linux\n"))
e9c6c584	127
cdea30e0 LC	128	(define (call-with-narinfo narinfo thunk)
	129	"Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
	130	a file for NARINFO."
	131	(let ((narinfo-directory (and=> (string->uri (getenv
	132	"GUIX_BINARY_SUBSTITUTE_URL"))
	133	uri-path))
	134	(cache-directory (string-append (getenv "XDG_CACHE_HOME")
	135	"/guix/substitute-binary/")))
	136	(dynamic-wind
	137	(lambda ()
	138	(when (file-exists? cache-directory)
	139	(delete-file-recursively cache-directory))
	140	(call-with-output-file (string-append narinfo-directory
	141	"/nix-cache-info")
	142	(lambda (port)
	143	(format port "StoreDir: ~a\nWantMassQuery: 0\n"
	144	(%store-prefix))))
	145	(call-with-output-file (string-append narinfo-directory "/"
	146	"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
	147	".narinfo")
	148	(cut display narinfo <>))
	149
e903b7c1 LC	150	;; Prepare the nar.
	151	(call-with-output-file
	152	(string-append narinfo-directory "/example.out")
	153	(cut display "Substitutable data." <>))
	154	(call-with-output-file
	155	(string-append narinfo-directory "/example.nar")
	156	(cute write-file
	157	(string-append narinfo-directory "/example.out") <>))
	158
cdea30e0 LC	159	(set! (@@ (guix scripts substitute-binary)
	160	%allow-unauthenticated-substitutes?)
	161	#f))
	162	thunk
	163	(lambda ()
	164	(delete-file-recursively cache-directory)))))
	165
	166	(define-syntax-rule (with-narinfo narinfo body ...)
	167	(call-with-narinfo narinfo (lambda () body ...)))
	168
4938b0ee LC	169	;; Transmit these options to 'guix substitute-binary'.
	170	(set! (@@ (guix scripts substitute-binary) %cache-url)
	171	(getenv "GUIX_BINARY_SUBSTITUTE_URL"))
cdea30e0	172
e903b7c1 LC	173	(test-equal "query narinfo without signature"
	174	"" ; not substitutable
	175
	176	(with-narinfo %narinfo
	177	(string-trim-both
	178	(with-output-to-string
	179	(lambda ()
	180	(with-input-from-string (string-append "have " (%store-prefix)
	181	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	182	(lambda ()
	183	(guix-substitute-binary "--query"))))))))
	184
cdea30e0	185	(test-equal "query narinfo with invalid hash"
52f80dfc	186	;; The hash in the signature differs from the hash of %NARINFO.
cdea30e0 LC	187	""
cdea30e0 LC	188
52f80dfc LC	189	(with-narinfo (string-append %narinfo "Signature: "
	190	(signature-field "different body")
	191	"\n")
cdea30e0 LC	192	(string-trim-both
	193	(with-output-to-string
	194	(lambda ()
	195	(with-input-from-string (string-append "have " (%store-prefix)
	196	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	197	(lambda ()
	198	(guix-substitute-binary "--query"))))))))
	199
	200	(test-equal "query narinfo signed with authorized key"
	201	(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	202
52f80dfc LC	203	(with-narinfo (string-append %narinfo "Signature: "
	204	(signature-field %narinfo)
	205	"\n")
cdea30e0 LC	206	(string-trim-both
	207	(with-output-to-string
	208	(lambda ()
	209	(with-input-from-string (string-append "have " (%store-prefix)
	210	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	211	(lambda ()
	212	(guix-substitute-binary "--query"))))))))
	213
	214	(test-equal "query narinfo signed with unauthorized key"
	215	"" ; not substitutable
	216
52f80dfc LC	217	(with-narinfo (string-append %narinfo "Signature: "
	218	(signature-field
	219	%narinfo
	220	#:public-key %wrong-public-key)
	221	"\n")
cdea30e0 LC	222	(string-trim-both
	223	(with-output-to-string
	224	(lambda ()
	225	(with-input-from-string (string-append "have " (%store-prefix)
	226	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	227	(lambda ()
	228	(guix-substitute-binary "--query"))))))))
	229
f84f8590 LC	230	(test-quit "substitute, no signature"
f84f8590 LC	231	"lacks a signature"
e903b7c1 LC	232	(with-narinfo %narinfo
	233	(guix-substitute-binary "--substitute"
	234	(string-append (%store-prefix)
	235	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	236	"foo")))
	237
f84f8590 LC	238	(test-quit "substitute, invalid hash"
f84f8590 LC	239	"hash"
52f80dfc LC	240	;; The hash in the signature differs from the hash of %NARINFO.
	241	(with-narinfo (string-append %narinfo "Signature: "
	242	(signature-field "different body")
	243	"\n")
cdea30e0 LC	244	(guix-substitute-binary "--substitute"
	245	(string-append (%store-prefix)
	246	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	247	"foo")))
	248
f84f8590 LC	249	(test-quit "substitute, unauthorized key"
f84f8590 LC	250	"unauthorized"
52f80dfc LC	251	(with-narinfo (string-append %narinfo "Signature: "
	252	(signature-field
	253	%narinfo
	254	#:public-key %wrong-public-key)
	255	"\n")
cdea30e0 LC	256	(guix-substitute-binary "--substitute"
	257	(string-append (%store-prefix)
	258	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	259	"foo")))
e9c6c584	260
e903b7c1 LC	261	(test-equal "substitute, authorized key"
	262	"Substitutable data."
	263	(with-narinfo (string-append %narinfo "Signature: "
	264	(signature-field %narinfo))
	265	(dynamic-wind
	266	(const #t)
	267	(lambda ()
	268	(guix-substitute-binary "--substitute"
	269	(string-append (%store-prefix)
	270	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	271	"substitute-retrieved")
	272	(call-with-input-file "substitute-retrieved" get-string-all))
	273	(lambda ()
	274	(false-if-exception (delete-file "substitute-retrieved"))))))
	275
e9c6c584 NK	276	(test-end "substitute-binary")
	277
	278	\f
	279	(exit (= (test-runner-fail-count (test-runner-current)) 0))
cdea30e0 LC	280
	281	;;; Local Variables:
	282	;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
f84f8590	283	;;; eval: (put 'test-quit 'scheme-indent-function 2)
cdea30e0	284	;;; End: