From accb682c5027cb91104cce7786f9dc4403adf51c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 21 Mar 2015 23:21:53 +0100 Subject: gexp: Allow objects in #:allowed-references. * guix/gexp.scm (lower-references): Add case. * tests/gexp.scm ("gexp->derivation #:allowed-references, specific output"): New test. --- tests/gexp.scm | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index 4c31e22f15..27c08467e7 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -497,6 +497,23 @@ (list "out" %bootstrap-guile)))) (built-derivations (list drv)))) +(test-assertm "gexp->derivation #:allowed-references, specific output" + (mlet* %store-monad ((in (gexp->derivation "thing" + #~(begin + (mkdir #$output:ok) + (mkdir #$output:not-ok)))) + (drv (gexp->derivation "allowed-refs" + #~(begin + (pk #$in:not-ok) + (mkdir #$output) + (chdir #$output) + (symlink #$output "self") + (symlink #$in:ok "ok")) + #:allowed-references + (list "out" + (gexp-input in "ok"))))) + (built-derivations (list drv)))) + (test-assert "gexp->derivation #:allowed-references, disallowed" (let ((drv (run-with-store %store (gexp->derivation "allowed-refs" -- cgit v1.2.3 From 1123759b4549bedc1a44b5d59a30c886e58ff6bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 22 Mar 2015 23:17:37 +0100 Subject: gexp: Fix handling of nativeness in nested gexps. * guix/gexp.scm (gexp-inputs): Remove 'references' parameter; add #:native? and honor it. [add-reference-inputs]: Distinguish between native gexp inputs, and non-native gexp inputs. Honor 'native?' field of list inputs. * tests/gexp.scm ("ungexp + ungexp-native, nested"): New test. --- tests/gexp.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index 27c08467e7..0540969503 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -160,6 +160,12 @@ (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) +(test-equal "ungexp + ungexp-native, nested" + (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) + (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) + (ungexp %bootstrap-guile))))) + (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (test-assert "input list" (let ((exp (gexp (display '(ungexp (list %bootstrap-guile coreutils))))) -- cgit v1.2.3 From 3681db5d2c3c40f8796703325242998bbdb48403 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2015 09:42:45 +0100 Subject: derivations: Add a 'cut?' parameter to 'derivation-prerequisites'. * guix/derivations.scm (valid-derivation-input?): New procedure. (derivation-prerequisites): Add 'cut?' parameter and honor it. * tests/derivations.scm ("derivation-prerequisites and derivation-input-is-valid?"): New test. --- tests/derivations.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 72d253c465..a8cccac34a 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -499,6 +499,20 @@ (string=? path (derivation-file-name (%guile-for-build))))) (derivation-prerequisites drv)))) +(test-assert "derivation-prerequisites and derivation-input-is-valid?" + (let* ((a (build-expression->derivation %store "a" '(mkdir %output))) + (b (build-expression->derivation %store "b" `(list ,(random-text)))) + (c (build-expression->derivation %store "c" `(mkdir %output) + #:inputs `(("a" ,a) ("b" ,b))))) + (build-derivations %store (list a)) + (match (derivation-prerequisites c + (cut valid-derivation-input? %store + <>)) + ((($ file ("out"))) + (string=? file (derivation-file-name b))) + (x + (pk 'fail x #f))))) + (test-assert "build-expression->derivation without inputs" (let* ((builder '(begin (mkdir %output) -- cgit v1.2.3 From 2c74fde00e4e721c6a73646935ab0cfe19dd9188 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2015 10:34:27 +0100 Subject: Rename 'guix substitute-binary' to 'guix substitute'. * guix/scripts/substitute-binary.scm: Rename to... * guix/scripts/substitute.scm: ... this. Adjust module name, entry point, comments, and help string accordingly. * nix/scripts/substitute-binary.in: Rename to... * nix/scripts/substitute.in: ... this. * pre-inst-env.in (NIX_SUBSTITUTERS): Adjust accordingly. * tests/substitute-binary.scm: Rename to... * tests/substitute.scm: ... this. Adjust references to (guix scripts substitute) accordingly. * guix/ui.scm (show-guix-help)[internal?]: Change "substitute-binary" to "substitute". * Makefile.am (MODULES, SCM_TESTS): Adjust to file renames. * daemon.am (nodist_pkglibexec_SCRIPTS): Likewise. * config-daemon.ac: Likewise. * guix/tests.scm (call-with-derivation-narinfo): Adjust comments and docstring. --- tests/store.scm | 10 +- tests/substitute-binary.scm | 284 -------------------------------------------- tests/substitute.scm | 284 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 289 insertions(+), 289 deletions(-) delete mode 100644 tests/substitute-binary.scm create mode 100644 tests/substitute.scm (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 9ed78be085..8e929bbc4d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -367,7 +367,7 @@ (with-store s (let* ((d (package-derivation s %bootstrap-guile (%current-system))) (o (derivation->output-path d))) - ;; Create fake substituter data, to be read by `substitute-binary'. + ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Remove entry from the local cache. (false-if-exception @@ -375,7 +375,7 @@ "/guix/substitute-binary/" (store-path-hash-part o)))) - ;; Make sure `substitute-binary' correctly communicates the above + ;; Make sure 'guix substitute' correctly communicates the above ;; data. (set-build-options s #:use-substitutes? #t) (and (has-substitutes? s o) @@ -439,7 +439,7 @@ (with-derivation-substitute d c (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C - ;; Make sure we use `substitute-binary'. + ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t #:fallback? #f) @@ -464,9 +464,9 @@ #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) - ;; Create fake substituter data, to be read by `substitute-binary'. + ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d - ;; Make sure we use `substitute-binary'. + ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t) (and (has-substitutes? s o) (guard (c ((nix-protocol-error? c) diff --git a/tests/substitute-binary.scm b/tests/substitute-binary.scm deleted file mode 100644 index 7c1204c1ab..0000000000 --- a/tests/substitute-binary.scm +++ /dev/null @@ -1,284 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014 Ludovic Courtès -;;; -;;; 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 . - -(define-module (test-substitute-binary) - #:use-module (guix scripts substitute-binary) - #:use-module (guix base64) - #:use-module (guix hash) - #:use-module (guix serialization) - #: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))) - - - -(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")))) - - - -(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") - - -(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: diff --git a/tests/substitute.scm b/tests/substitute.scm new file mode 100644 index 0000000000..5697592423 --- /dev/null +++ b/tests/substitute.scm @@ -0,0 +1,284 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Nikita Karetnikov +;;; Copyright © 2014, 2015 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-substitute) + #:use-module (guix scripts substitute) + #:use-module (guix base64) + #:use-module (guix hash) + #:use-module (guix serialization) + #: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))) + + + +(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")))) + + + +(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) + %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'. +(set! (@@ (guix scripts substitute) %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 "--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 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" + "lacks a signature" + (with-narinfo %narinfo + (guix-substitute "--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 "--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 "--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-end "substitute") + + +(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: -- cgit v1.2.3 From 614c2188420a266ec512c9c04af3bb2ea46c4dc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Mar 2015 10:44:19 +0100 Subject: substitute: Rename cache directory from "substitute-binary" to "substitute". * guix/scripts/substitute.scm (%narinfo-cache-directory): Change "substitute-binary" to "substitute". * tests/store.scm ("substitute query"): Likewise. * tests/substitute.scm (call-with-narinfo): Likewise. --- tests/store.scm | 2 +- tests/substitute.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/store.scm b/tests/store.scm index 8e929bbc4d..f778c2086d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -372,7 +372,7 @@ ;; Remove entry from the local cache. (false-if-exception (delete-file (string-append (getenv "XDG_CACHE_HOME") - "/guix/substitute-binary/" + "/guix/substitute/" (store-path-hash-part o)))) ;; Make sure 'guix substitute' correctly communicates the above diff --git a/tests/substitute.scm b/tests/substitute.scm index 5697592423..85698127fa 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -132,7 +132,7 @@ a file for NARINFO." "GUIX_BINARY_SUBSTITUTE_URL")) uri-path)) (cache-directory (string-append (getenv "XDG_CACHE_HOME") - "/guix/substitute-binary/"))) + "/guix/substitute/"))) (dynamic-wind (lambda () (when (file-exists? cache-directory) -- cgit v1.2.3