X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/e82e55e58c67b0215e768c4612ca542bc670f633..1d684aedf839ca35c2f8784f168fd56835402ab6:/tests/substitute.scm diff --git a/tests/substitute.scm b/tests/substitute.scm index 9d907e7abf..697abc4684 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,20 +19,27 @@ (define-module (test-substitute) #:use-module (guix scripts substitute) + #:use-module (guix narinfo) #:use-module (guix base64) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix serialization) - #:use-module (guix pk-crypto) + #: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 build utils) #:select (delete-file-recursively)) + #:use-module ((guix utils) + #:select (call-with-temporary-directory + call-with-compressed-output-port)) + #: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-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -44,7 +51,8 @@ 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)) + (parameterize ((current-error-port error-output) + (guix-warning-port error-output)) (catch 'quit (lambda () exp @@ -54,6 +62,14 @@ it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." (let ((message (get-output-string error-output))) (->bool (string-match error-rx message)))))))))) +(define (request-substitution item destination) + "Run 'guix substitute --substitute' to fetch ITEM to DESTINATION." + (parameterize ((guix-warning-port (current-error-port))) + (with-input-from-string (string-append "substitute " item " " + destination "\n") + (lambda () + (guix-substitute "--substitute"))))) + (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") @@ -112,6 +128,15 @@ version identifier.." +(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) @@ -125,14 +150,14 @@ 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 +(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." - (let ((narinfo-directory (and=> (string->uri (getenv - "GUIX_BINARY_SUBSTITUTE_URL")) - uri-path)) - (cache-directory (string-append (getenv "XDG_CACHE_HOME") - "/guix/substitute/"))) + (mkdir-p narinfo-directory) + (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME") + "/guix/substitute/"))) (dynamic-wind (lambda () (when (file-exists? cache-directory) @@ -156,20 +181,26 @@ a file for NARINFO." (cute write-file (string-append narinfo-directory "/example.out") <>)) - (set! (@@ (guix scripts substitute) - %allow-unauthenticated-substitutes?) - #f)) + (%allow-unauthenticated-substitutes? #f)) thunk (lambda () - (delete-file-recursively cache-directory))))) + (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'. -(set! (@@ (guix scripts substitute) %cache-urls) - (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))) +(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))) +;; Never use file descriptor 4, unlike what happens when invoked by the +;; daemon. +(%error-to-file-descriptor-4? #f) + + (test-equal "query narinfo without signature" "" ; not substitutable @@ -197,6 +228,46 @@ a file for NARINFO." (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") @@ -228,57 +299,296 @@ a file for NARINFO." (guix-substitute "--query")))))))) (test-quit "substitute, no signature" - "lacks a signature" + "no valid substitute" (with-narinfo %narinfo - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) -(test-quit "substitute, invalid hash" - "hash" +(test-quit "substitute, invalid narinfo 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"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) + +(test-equal "substitute, invalid hash" + (string-append "hash-mismatch sha256 " + (bytevector->nix-base32-string (sha256 #vu8())) " " + (let-values (((port get-hash) + (open-hash-port (hash-algorithm sha256))) + ((content) + "Substitutable data.")) + (write-file-tree "foo" port + #:file-type+size + (lambda _ + (values 'regular + (string-length content))) + #:file-port + (lambda _ + (open-input-string content))) + (close-port port) + (bytevector->nix-base32-string (get-hash))) + "\n") + + ;; Arrange so the actual data hash does not match the 'NarHash' field in the + ;; narinfo. + (with-output-to-string + (lambda () + (let ((narinfo (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) " +NarSize: 42 +References: +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n"))) + (with-narinfo (string-append narinfo "Signature: " + (signature-field narinfo) "\n") + (call-with-temporary-directory + (lambda (directory) + (with-input-from-string (string-append + "substitute " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash " + directory "/wrong-hash\n") + (lambda () + (guix-substitute "--substitute")))))))))) (test-quit "substitute, unauthorized key" - "unauthorized" + "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"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) (test-equal "substitute, authorized key" - "Substitutable data." + '("Substitutable data." 1 #o444) (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)) + (request-substitution (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "substitute-retrieved") + (list (call-with-input-file "substitute-retrieved" get-string-all) + (stat:mtime (lstat "substitute-retrieved")) + (stat:perms (lstat "substitute-retrieved")))) (lambda () (false-if-exception (delete-file "substitute-retrieved")))))) -(test-end "substitute") +(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)))) + (request-substitution (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)))) + (request-substitution (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)))) + (request-substitution (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)))) + (request-substitution (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 + + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " substitute-retrieved\n") + (lambda () + (guix-substitute "--substitute")))))) + +(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) + (compress nar (string-append nar ".lz") 'lzip)) + + (parameterize ((substitute-urls + (list (string-append "file://" + %main-substitute-directory)))) + (request-substitution (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"))))))) - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) +(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: