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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015, 2017, 2018 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)
  #:use-module (guix scripts substitute)
  #:use-module (guix base64)
  #:use-module (gcrypt hash)
  #:use-module (guix serialization)
  #:use-module (gcrypt 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 utils) #:select (call-with-compressed-output-port))
  #:use-module ((guix lzlib) #:select (lzlib-available?))
  #:use-module ((guix build utils)
                #:select (mkdir-p delete-file-recursively dump-port))
  #:use-module (guix tests http)
  #: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")

(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 %main-substitute-directory
  ;; The place where 'call-with-narinfo' stores its data by default.
  (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))

(define %alternate-substitute-directory
  ;; Another place.
  (string-append (dirname %main-substitute-directory)
                 "/substituter-alt-data"))

(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
                            #:optional
                            (narinfo-directory %main-substitute-directory))
  "Call THUNK in a context where the directory at URL is populated with
a file for NARINFO."
  (mkdir-p narinfo-directory)
  (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
                                        "/guix/substitute/")))
    (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)
                  %allow-unauthenticated-substitutes?)
              #f))
      thunk
      (lambda ()
        (when (file-exists? cache-directory)
          (delete-file-recursively cache-directory))))))

(define-syntax-rule (with-narinfo narinfo body ...)
  (call-with-narinfo narinfo (lambda () body ...)))

(define-syntax-rule (with-narinfo* narinfo directory body ...)
  (call-with-narinfo narinfo (lambda () body ...) directory))

;; Transmit these options to 'guix substitute'.
(substitute-urls (list (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 "--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 "--query"))))))))

(test-equal "query narinfo with signature over nothing"
  ;; The signature is computed over the empty string, not over the important
  ;; parts, so the narinfo must be ignored.
  ""

  (with-narinfo (string-append "Signature: " (signature-field "") "\n"
                                %narinfo "\n")
    (string-trim-both
     (with-output-to-string
       (lambda ()
         (with-input-from-string (string-append "have " (%store-prefix)
                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
           (lambda ()
             (guix-substitute "--query"))))))))

(test-equal "query narinfo with signature over irrelevant bits"
  ;; The signature is valid but it does not cover the
  ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
  ;; must be ignored.
  ""

  (let ((prefix (string-append "StorePath: " (%store-prefix)
                               "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
URL: example.nar
Compression: none\n")))
    (with-narinfo (string-append prefix
                                 "Signature: " (signature-field prefix) "
NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
NarSize: 42
References: bar baz
Deriver: " (%store-prefix) "/foo.drv
System: mips64el-linux\n")
      (string-trim-both
       (with-output-to-string
         (lambda ()
           (with-input-from-string (string-append "have " (%store-prefix)
                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
             (lambda ()
               (guix-substitute "--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 "--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 "--query"))))))))

(test-quit "substitute, no signature"
    "no valid substitute"
  (with-narinfo %narinfo
    (guix-substitute "--substitute"
                     (string-append (%store-prefix)
                                    "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                     "foo")))

(test-quit "substitute, invalid hash"
    "no valid substitute"
  ;; The hash in the signature differs from the hash of %NARINFO.
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field "different body")
                               "\n")
    (guix-substitute "--substitute"
                     (string-append (%store-prefix)
                                    "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                     "foo")))

(test-quit "substitute, unauthorized key"
    "no valid substitute"
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field
                                %narinfo
                                #:public-key %wrong-public-key)
                               "\n")
    (guix-substitute "--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 "--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-equal "substitute, unauthorized narinfo comes first"
  "Substitutable data."
  (with-narinfo*
      (string-append %narinfo "Signature: "
                     (signature-field
                      %narinfo
                      #:public-key %wrong-public-key))
      %alternate-substitute-directory

    (with-narinfo* (string-append %narinfo "Signature: "
                                  (signature-field %narinfo))
        %main-substitute-directory

      (dynamic-wind
        (const #t)
        (lambda ()
          ;; Remove this file so that the substitute can only be retrieved
          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
          (delete-file (string-append %main-substitute-directory
                                      "/example.nar"))

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--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-equal "substitute, unsigned narinfo comes first"
  "Substitutable data."
  (with-narinfo* %narinfo                         ;not signed!
      %alternate-substitute-directory

    (with-narinfo* (string-append %narinfo "Signature: "
                                  (signature-field %narinfo))
        %main-substitute-directory

      (dynamic-wind
        (const #t)
        (lambda ()
          ;; Remove this file so that the substitute can only be retrieved
          ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
          (delete-file (string-append %main-substitute-directory
                                      "/example.nar"))

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--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-equal "substitute, first narinfo is unsigned and has wrong hash"
  "Substitutable data."
  (with-narinfo* (regexp-substitute #f
                                    (string-match "NarHash: [[:graph:]]+"
                                                  %narinfo)
                                    'pre
                                    "NarHash: sha256:"
                                    (bytevector->nix-base32-string
                                     (make-bytevector 32))
                                    'post)
      %alternate-substitute-directory

    (with-narinfo* (string-append %narinfo "Signature: "
                                  (signature-field %narinfo))
        %main-substitute-directory

      (dynamic-wind
        (const #t)
        (lambda ()
          ;; This time remove the file so that the substitute can only be
          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
          (delete-file (string-append %alternate-substitute-directory
                                      "/example.nar"))

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--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-equal "substitute, first narinfo is unsigned and has wrong refs"
  "Substitutable data."
  (with-narinfo* (regexp-substitute #f
                                    (string-match "References: ([^\n]+)\n"
                                                  %narinfo)
                                    'pre "References: " 1
                                    " wrong set of references\n"
                                    'post)
      %alternate-substitute-directory

    (with-narinfo* (string-append %narinfo "Signature: "
                                  (signature-field %narinfo))
        %main-substitute-directory

      (dynamic-wind
        (const #t)
        (lambda ()
          ;; This time remove the file so that the substitute can only be
          ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
          (delete-file (string-append %alternate-substitute-directory
                                      "/example.nar"))

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--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-quit "substitute, two invalid narinfos"
    "no valid substitute"
  (with-narinfo* %narinfo                         ;not signed
      %alternate-substitute-directory

    (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
                                  (signature-field
                                   %narinfo
                                   #:public-key %wrong-public-key))
        %main-substitute-directory

      (guix-substitute "--substitute"
                       (string-append (%store-prefix)
                                      "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                       "substitute-retrieved"))))

(test-equal "substitute, narinfo with several URLs"
  "Substitutable data."
  (let ((narinfo (string-append "StorePath: " (%store-prefix)
                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
URL: example.nar.gz
Compression: gzip
URL: example.nar.lz
Compression: lzip
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")))
    (with-narinfo (string-append narinfo "Signature: "
                                 (signature-field narinfo))
      (dynamic-wind
        (const #t)
        (lambda ()
          (define (compress input output compression)
            (call-with-output-file output
              (lambda (port)
                (call-with-compressed-output-port compression port
                  (lambda (port)
                    (call-with-input-file input
                      (lambda (input)
                        (dump-port input port))))))))

          (let ((nar (string-append %main-substitute-directory
                                    "/example.nar")))
            (compress nar (string-append nar ".gz") 'gzip)
            (when (lzlib-available?)
              (compress nar (string-append nar ".lz") 'lzip)))

          (parameterize ((substitute-urls
                          (list (string-append "file://"
                                               %main-substitute-directory))))
            (guix-substitute "--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")

;;; Local Variables:
;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
;;; eval: (put 'test-quit 'scheme-indent-function 2)
;;; End:
Commit	Line	Data
e9c6c584 NK	1	;;; GNU Guix --- Functional package management for GNU
e9c6c584 NK	2	;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
60b04024	3	;;; Copyright © 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
e9c6c584 NK	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
2c74fde0 LC	20	(define-module (test-substitute)
2c74fde0 LC	21	#:use-module (guix scripts substitute)
e9c6c584	22	#:use-module (guix base64)
ca719424	23	#:use-module (gcrypt hash)
0363991a	24	#:use-module (guix serialization)
ca719424	25	#:use-module (gcrypt pk-crypto)
e9c6c584	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))
b90ae065 LC	31	#:use-module ((guix utils) #:select (call-with-compressed-output-port))
b90ae065 LC	32	#:use-module ((guix lzlib) #:select (lzlib-available?))
a9468b42	33	#:use-module ((guix build utils)
b90ae065	34	#:select (mkdir-p delete-file-recursively dump-port))
a9468b42	35	#:use-module (guix tests http)
e9c6c584	36	#:use-module (rnrs bytevectors)
cdea30e0 LC	37	#:use-module (rnrs io ports)
cdea30e0 LC	38	#:use-module (web uri)
52f80dfc	39	#:use-module (ice-9 regex)
cdea30e0	40	#:use-module (srfi srfi-26)
e9c6c584	41	#:use-module (srfi srfi-34)
52f80dfc	42	#:use-module (srfi srfi-35)
e9c6c584 NK	43	#:use-module ((srfi srfi-64) #:hide (test-error)))
e9c6c584 NK	44
f84f8590 LC	45	(define-syntax-rule (test-quit name error-rx exp)
	46	"Emit a test that passes when EXP throws to 'quit' with value 1, and when
	47	it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
cdea30e0	48	(test-equal name
f84f8590 LC	49	'(1 #t)
	50	(let ((error-output (open-output-string)))
	51	(parameterize ((guix-warning-port error-output))
	52	(catch 'quit
	53	(lambda ()
	54	exp
	55	#f)
	56	(lambda (key value)
	57	(list value
	58	(let ((message (get-output-string error-output)))
	59	(->bool (string-match error-rx message))))))))))
e9c6c584 NK	60
e9c6c584 NK	61	(define %public-key
cdea30e0 LC	62	;; This key is known to be in the ACL by default.
	63	(call-with-input-file (string-append %config-directory "/signing-key.pub")
	64	(compose string->canonical-sexp get-string-all)))
e9c6c584 NK	65
e9c6c584 NK	66	(define %private-key
cdea30e0 LC	67	(call-with-input-file (string-append %config-directory "/signing-key.sec")
cdea30e0 LC	68	(compose string->canonical-sexp get-string-all)))
e9c6c584	69
52f80dfc LC	70	(define* (signature-body bv #:key (public-key %public-key))
52f80dfc LC	71	"Return the signature of BV as the base64-encoded body of a narinfo's
cdea30e0	72	'Signature' field."
e9c6c584 NK	73	(base64-encode
	74	(string->utf8
	75	(canonical-sexp->string
52f80dfc	76	(signature-sexp (bytevector->hash-data (sha256 bv)
e9c6c584 NK	77	#:key-type 'rsa)
e9c6c584 NK	78	%private-key
cdea30e0	79	public-key)))))
e9c6c584	80
e9c6c584 NK	81	(define %wrong-public-key
	82	(string->canonical-sexp "(public-key
	83	(rsa
	84	(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
	85	(e #010001#)
	86	)
	87	)"))
	88
52f80dfc LC	89	(define* (signature-field bv-or-str
	90	#:key (version "1") (public-key %public-key))
	91	"Return the 'Signature' field value of bytevector/string BV-OR-STR, using
	92	PUBLIC-KEY as the signature's principal, and using VERSION as the signature
	93	version identifier.."
	94	(string-append version ";example.gnu.org;"
	95	(signature-body (if (string? bv-or-str)
	96	(string->utf8 bv-or-str)
	97	bv-or-str)
	98	#:public-key public-key)))
	99
e9c6c584	100
cdea30e0	101	\f
2c74fde0	102	(test-begin "substitute")
e9c6c584	103
f84f8590 LC	104	(test-quit "not a number"
f84f8590 LC	105	"signature version"
52f80dfc LC	106	(narinfo-signature->canonical-sexp
52f80dfc LC	107	(signature-field "foo" #:version "not a number")))
e9c6c584	108
f84f8590 LC	109	(test-quit "wrong version number"
f84f8590 LC	110	"unsupported.*version"
52f80dfc LC	111	(narinfo-signature->canonical-sexp
52f80dfc LC	112	(signature-field "foo" #:version "2")))
e9c6c584 NK	113
e9c6c584 NK	114	(test-assert "valid narinfo-signature->canonical-sexp"
52f80dfc	115	(canonical-sexp? (narinfo-signature->canonical-sexp (signature-field "foo"))))
e9c6c584	116
e9c6c584	117
cdea30e0	118	\f
a9468b42 LC	119	(define %main-substitute-directory
	120	;; The place where 'call-with-narinfo' stores its data by default.
	121	(uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
	122
	123	(define %alternate-substitute-directory
	124	;; Another place.
	125	(string-append (dirname %main-substitute-directory)
	126	"/substituter-alt-data"))
	127
e9c6c584	128	(define %narinfo
52f80dfc	129	;; Skeleton of the narinfo used below.
cdea30e0 LC	130	(string-append "StorePath: " (%store-prefix)
cdea30e0 LC	131	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
e903b7c1 LC	132	URL: example.nar
	133	Compression: none
	134	NarHash: sha256:" (bytevector->nix-base32-string
	135	(sha256 (string->utf8 "Substitutable data."))) "
e9c6c584 NK	136	NarSize: 42
e9c6c584 NK	137	References: bar baz
cdea30e0 LC	138	Deriver: " (%store-prefix) "/foo.drv
cdea30e0 LC	139	System: mips64el-linux\n"))
e9c6c584	140
a9468b42 LC	141	(define* (call-with-narinfo narinfo thunk
	142	#:optional
	143	(narinfo-directory %main-substitute-directory))
	144	"Call THUNK in a context where the directory at URL is populated with
cdea30e0	145	a file for NARINFO."
a9468b42 LC	146	(mkdir-p narinfo-directory)
	147	(let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
	148	"/guix/substitute/")))
cdea30e0 LC	149	(dynamic-wind
	150	(lambda ()
	151	(when (file-exists? cache-directory)
	152	(delete-file-recursively cache-directory))
	153	(call-with-output-file (string-append narinfo-directory
	154	"/nix-cache-info")
	155	(lambda (port)
	156	(format port "StoreDir: ~a\nWantMassQuery: 0\n"
	157	(%store-prefix))))
	158	(call-with-output-file (string-append narinfo-directory "/"
	159	"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
	160	".narinfo")
	161	(cut display narinfo <>))
	162
e903b7c1 LC	163	;; Prepare the nar.
	164	(call-with-output-file
	165	(string-append narinfo-directory "/example.out")
	166	(cut display "Substitutable data." <>))
	167	(call-with-output-file
	168	(string-append narinfo-directory "/example.nar")
	169	(cute write-file
	170	(string-append narinfo-directory "/example.out") <>))
	171
2c74fde0	172	(set! (@@ (guix scripts substitute)
cdea30e0 LC	173	%allow-unauthenticated-substitutes?)
	174	#f))
	175	thunk
	176	(lambda ()
a9468b42 LC	177	(when (file-exists? cache-directory)
a9468b42 LC	178	(delete-file-recursively cache-directory))))))
cdea30e0 LC	179
	180	(define-syntax-rule (with-narinfo narinfo body ...)
	181	(call-with-narinfo narinfo (lambda () body ...)))
	182
a9468b42 LC	183	(define-syntax-rule (with-narinfo* narinfo directory body ...)
	184	(call-with-narinfo narinfo (lambda () body ...) directory))
	185
2c74fde0	186	;; Transmit these options to 'guix substitute'.
218f6ecc	187	(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
cdea30e0	188
e903b7c1 LC	189	(test-equal "query narinfo without signature"
	190	"" ; not substitutable
	191
	192	(with-narinfo %narinfo
	193	(string-trim-both
	194	(with-output-to-string
	195	(lambda ()
	196	(with-input-from-string (string-append "have " (%store-prefix)
	197	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	198	(lambda ()
2c74fde0	199	(guix-substitute "--query"))))))))
e903b7c1	200
cdea30e0	201	(test-equal "query narinfo with invalid hash"
52f80dfc	202	;; The hash in the signature differs from the hash of %NARINFO.
cdea30e0 LC	203	""
cdea30e0 LC	204
52f80dfc LC	205	(with-narinfo (string-append %narinfo "Signature: "
	206	(signature-field "different body")
	207	"\n")
cdea30e0 LC	208	(string-trim-both
	209	(with-output-to-string
	210	(lambda ()
	211	(with-input-from-string (string-append "have " (%store-prefix)
	212	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	213	(lambda ()
2c74fde0	214	(guix-substitute "--query"))))))))
cdea30e0	215
60b04024 LC	216	(test-equal "query narinfo with signature over nothing"
	217	;; The signature is computed over the empty string, not over the important
	218	;; parts, so the narinfo must be ignored.
	219	""
	220
	221	(with-narinfo (string-append "Signature: " (signature-field "") "\n"
	222	%narinfo "\n")
	223	(string-trim-both
	224	(with-output-to-string
	225	(lambda ()
	226	(with-input-from-string (string-append "have " (%store-prefix)
	227	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	228	(lambda ()
	229	(guix-substitute "--query"))))))))
	230
	231	(test-equal "query narinfo with signature over irrelevant bits"
	232	;; The signature is valid but it does not cover the
	233	;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
	234	;; must be ignored.
	235	""
	236
	237	(let ((prefix (string-append "StorePath: " (%store-prefix)
	238	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
	239	URL: example.nar
	240	Compression: none\n")))
	241	(with-narinfo (string-append prefix
	242	"Signature: " (signature-field prefix) "
	243	NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
	244	NarSize: 42
	245	References: bar baz
	246	Deriver: " (%store-prefix) "/foo.drv
	247	System: mips64el-linux\n")
	248	(string-trim-both
	249	(with-output-to-string
	250	(lambda ()
	251	(with-input-from-string (string-append "have " (%store-prefix)
	252	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	253	(lambda ()
	254	(guix-substitute "--query")))))))))
	255
cdea30e0 LC	256	(test-equal "query narinfo signed with authorized key"
	257	(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	258
52f80dfc LC	259	(with-narinfo (string-append %narinfo "Signature: "
	260	(signature-field %narinfo)
	261	"\n")
cdea30e0 LC	262	(string-trim-both
	263	(with-output-to-string
	264	(lambda ()
	265	(with-input-from-string (string-append "have " (%store-prefix)
	266	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	267	(lambda ()
2c74fde0	268	(guix-substitute "--query"))))))))
cdea30e0 LC	269
	270	(test-equal "query narinfo signed with unauthorized key"
	271	"" ; not substitutable
	272
52f80dfc LC	273	(with-narinfo (string-append %narinfo "Signature: "
	274	(signature-field
	275	%narinfo
	276	#:public-key %wrong-public-key)
	277	"\n")
cdea30e0 LC	278	(string-trim-both
	279	(with-output-to-string
	280	(lambda ()
	281	(with-input-from-string (string-append "have " (%store-prefix)
	282	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	283	(lambda ()
2c74fde0	284	(guix-substitute "--query"))))))))
cdea30e0	285
f84f8590	286	(test-quit "substitute, no signature"
a9468b42	287	"no valid substitute"
e903b7c1	288	(with-narinfo %narinfo
2c74fde0 LC	289	(guix-substitute "--substitute"
	290	(string-append (%store-prefix)
	291	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	292	"foo")))
e903b7c1	293
f84f8590	294	(test-quit "substitute, invalid hash"
a9468b42	295	"no valid substitute"
52f80dfc LC	296	;; The hash in the signature differs from the hash of %NARINFO.
	297	(with-narinfo (string-append %narinfo "Signature: "
	298	(signature-field "different body")
	299	"\n")
2c74fde0 LC	300	(guix-substitute "--substitute"
	301	(string-append (%store-prefix)
	302	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	303	"foo")))
cdea30e0	304
f84f8590	305	(test-quit "substitute, unauthorized key"
a9468b42	306	"no valid substitute"
52f80dfc LC	307	(with-narinfo (string-append %narinfo "Signature: "
	308	(signature-field
	309	%narinfo
	310	#:public-key %wrong-public-key)
	311	"\n")
2c74fde0 LC	312	(guix-substitute "--substitute"
	313	(string-append (%store-prefix)
	314	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	315	"foo")))
e9c6c584	316
e903b7c1 LC	317	(test-equal "substitute, authorized key"
	318	"Substitutable data."
	319	(with-narinfo (string-append %narinfo "Signature: "
	320	(signature-field %narinfo))
	321	(dynamic-wind
	322	(const #t)
	323	(lambda ()
2c74fde0 LC	324	(guix-substitute "--substitute"
	325	(string-append (%store-prefix)
	326	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	327	"substitute-retrieved")
e903b7c1 LC	328	(call-with-input-file "substitute-retrieved" get-string-all))
	329	(lambda ()
	330	(false-if-exception (delete-file "substitute-retrieved"))))))
	331
a9468b42 LC	332	(test-equal "substitute, unauthorized narinfo comes first"
	333	"Substitutable data."
	334	(with-narinfo*
	335	(string-append %narinfo "Signature: "
	336	(signature-field
	337	%narinfo
	338	#:public-key %wrong-public-key))
	339	%alternate-substitute-directory
	340
	341	(with-narinfo* (string-append %narinfo "Signature: "
	342	(signature-field %narinfo))
	343	%main-substitute-directory
	344
	345	(dynamic-wind
	346	(const #t)
	347	(lambda ()
	348	;; Remove this file so that the substitute can only be retrieved
	349	;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
	350	(delete-file (string-append %main-substitute-directory
	351	"/example.nar"))
	352
	353	(parameterize ((substitute-urls
	354	(map (cut string-append "file://" <>)
	355	(list %alternate-substitute-directory
	356	%main-substitute-directory))))
	357	(guix-substitute "--substitute"
	358	(string-append (%store-prefix)
	359	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	360	"substitute-retrieved"))
	361	(call-with-input-file "substitute-retrieved" get-string-all))
	362	(lambda ()
	363	(false-if-exception (delete-file "substitute-retrieved")))))))
	364
	365	(test-equal "substitute, unsigned narinfo comes first"
	366	"Substitutable data."
	367	(with-narinfo* %narinfo ;not signed!
	368	%alternate-substitute-directory
	369
	370	(with-narinfo* (string-append %narinfo "Signature: "
	371	(signature-field %narinfo))
	372	%main-substitute-directory
	373
	374	(dynamic-wind
	375	(const #t)
	376	(lambda ()
	377	;; Remove this file so that the substitute can only be retrieved
	378	;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
	379	(delete-file (string-append %main-substitute-directory
	380	"/example.nar"))
	381
	382	(parameterize ((substitute-urls
	383	(map (cut string-append "file://" <>)
	384	(list %alternate-substitute-directory
	385	%main-substitute-directory))))
	386	(guix-substitute "--substitute"
	387	(string-append (%store-prefix)
	388	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	389	"substitute-retrieved"))
	390	(call-with-input-file "substitute-retrieved" get-string-all))
	391	(lambda ()
	392	(false-if-exception (delete-file "substitute-retrieved")))))))
	393
	394	(test-equal "substitute, first narinfo is unsigned and has wrong hash"
	395	"Substitutable data."
396	(with-narinfo* (regexp-substitute #f
397	(string-match "NarHash: [[:graph:]]+"
398	%narinfo)
399	'pre
400	"NarHash: sha256:"
401	(bytevector->nix-base32-string
402	(make-bytevector 32))
403	'post)
404	%alternate-substitute-directory
405
406	(with-narinfo* (string-append %narinfo "Signature: "
407	(signature-field %narinfo))
408	%main-substitute-directory
409
410	(dynamic-wind
411	(const #t)
412	(lambda ()
413	;; This time remove the file so that the substitute can only be
414	;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
415	(delete-file (string-append %alternate-substitute-directory
416	"/example.nar"))
417
418	(parameterize ((substitute-urls
419	(map (cut string-append "file://" <>)
420	(list %alternate-substitute-directory
421	%main-substitute-directory))))
422	(guix-substitute "--substitute"
423	(string-append (%store-prefix)
424	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
425	"substitute-retrieved"))
426	(call-with-input-file "substitute-retrieved" get-string-all))
427	(lambda ()
428	(false-if-exception (delete-file "substitute-retrieved")))))))
429
430	(test-equal "substitute, first narinfo is unsigned and has wrong refs"
431	"Substitutable data."
432	(with-narinfo* (regexp-substitute #f
433	(string-match "References: ([^\n]+)\n"
434	%narinfo)
435	'pre "References: " 1
436	" wrong set of references\n"
437	'post)
438	%alternate-substitute-directory
439
440	(with-narinfo* (string-append %narinfo "Signature: "
441	(signature-field %narinfo))
442	%main-substitute-directory
443
444	(dynamic-wind
445	(const #t)
446	(lambda ()
447	;; This time remove the file so that the substitute can only be
448	;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
449	(delete-file (string-append %alternate-substitute-directory
450	"/example.nar"))
451
452	(parameterize ((substitute-urls
453	(map (cut string-append "file://" <>)
454	(list %alternate-substitute-directory
455	%main-substitute-directory))))
456	(guix-substitute "--substitute"
457	(string-append (%store-prefix)
458	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
459	"substitute-retrieved"))
460	(call-with-input-file "substitute-retrieved" get-string-all))
461	(lambda ()
462	(false-if-exception (delete-file "substitute-retrieved")))))))
463
464	(test-quit "substitute, two invalid narinfos"
465	"no valid substitute"
466	(with-narinfo* %narinfo ;not signed
467	%alternate-substitute-directory
468
469	(with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
470	(signature-field
471	%narinfo
472	#:public-key %wrong-public-key))
473	%main-substitute-directory
474
475	(guix-substitute "--substitute"
476	(string-append (%store-prefix)
477	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
478	"substitute-retrieved"))))
479
b90ae065 LC	480	(test-equal "substitute, narinfo with several URLs"
	481	"Substitutable data."
	482	(let ((narinfo (string-append "StorePath: " (%store-prefix)
	483	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
	484	URL: example.nar.gz
	485	Compression: gzip
	486	URL: example.nar.lz
	487	Compression: lzip
	488	URL: example.nar
	489	Compression: none
	490	NarHash: sha256:" (bytevector->nix-base32-string
	491	(sha256 (string->utf8 "Substitutable data."))) "
	492	NarSize: 42
	493	References: bar baz
	494	Deriver: " (%store-prefix) "/foo.drv
	495	System: mips64el-linux\n")))
	496	(with-narinfo (string-append narinfo "Signature: "
	497	(signature-field narinfo))
	498	(dynamic-wind
	499	(const #t)
	500	(lambda ()
	501	(define (compress input output compression)
	502	(call-with-output-file output
	503	(lambda (port)
	504	(call-with-compressed-output-port compression port
	505	(lambda (port)
	506	(call-with-input-file input
	507	(lambda (input)
	508	(dump-port input port))))))))
	509
	510	(let ((nar (string-append %main-substitute-directory
	511	"/example.nar")))
	512	(compress nar (string-append nar ".gz") 'gzip)
	513	(when (lzlib-available?)
	514	(compress nar (string-append nar ".lz") 'lzip)))
	515
	516	(parameterize ((substitute-urls
	517	(list (string-append "file://"
	518	%main-substitute-directory))))
	519	(guix-substitute "--substitute"
	520	(string-append (%store-prefix)
	521	"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
	522	"substitute-retrieved"))
	523	(call-with-input-file "substitute-retrieved" get-string-all))
	524	(lambda ()
	525	(false-if-exception (delete-file "substitute-retrieved")))))))
	526
2c74fde0	527	(test-end "substitute")
e9c6c584	528
cdea30e0 LC	529	;;; Local Variables:
cdea30e0 LC	530	;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
a9468b42	531	;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
f84f8590	532	;;; eval: (put 'test-quit 'scheme-indent-function 2)
cdea30e0	533	;;; End: