;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(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)
(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
(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")
\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)
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)
(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)
+
+\f
(test-equal "query narinfo without signature"
"" ; not substitutable
(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")
(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-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")))))))
+
(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:
HCoop / jackhill / guix / guix.git / blobdiff