code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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-store)
  #:use-module (guix tests)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix monads)
  #:use-module ((gcrypt hash) #:prefix gcrypt:)
  #:use-module ((gcrypt pk-crypto) #:prefix gcrypt:)
  #:use-module (guix pki)
  #:use-module (guix base32)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix serialization)
  #:use-module (guix build utils)
  #:use-module (guix gexp)
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

;; Test the (guix store) module.

(define %store
  (open-connection-for-tests))

(define %shell
  (or (getenv "SHELL") (getenv "CONFIG_SHELL") "/bin/sh"))

(test-begin "store")

(test-assert "open-connection with file:// URI"
  (let ((store (open-connection (string-append "file://"
                                               (%daemon-socket-uri)))))
    (and (add-text-to-store store "foo" "bar")
         (begin
           (close-connection store)
           #t))))

(test-equal "connection handshake error"
  EPROTO
  (let ((port (%make-void-port "rw")))
    (guard (c ((store-connection-error? c)
               (and (eq? port (store-connection-error-file c))
                    (store-connection-error-code c))))
      (open-connection #f #:port port)
      'broken)))

(test-equal "store-path-hash-part"
  "283gqy39v3g9dxjy26rynl0zls82fmcg"
  (store-path-hash-part
   (string-append (%store-prefix)
                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-hash-part #f"
  #f
  (store-path-hash-part
   (string-append (%store-prefix)
                  "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-package-name"
  "guile-2.0.7"
  (store-path-package-name
   (string-append (%store-prefix)
                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-package-name #f"
  #f
  (store-path-package-name
   "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))

(test-assert "direct-store-path?"
  (and (direct-store-path?
        (string-append (%store-prefix)
                       "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
       (not (direct-store-path?
             (string-append
              (%store-prefix)
              "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
       (not (direct-store-path? (%store-prefix)))))

(test-skip (if %store 0 15))

(test-equal "profiles/per-user exists and is not writable"
  #o755
  (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))

(test-equal "profiles/per-user/$USER exists"
  (list (getuid) #o755)
  (let ((s (stat (string-append %state-directory "/profiles/per-user/"
                                (passwd:name (getpwuid (getuid)))))))
    (list (stat:uid s) (stat:perms s))))

(test-equal "add-to-store"
  '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256")
  (let* ((file    (search-path %load-path "guix.scm"))
         (content (call-with-input-file file get-bytevector-all)))
    (map (lambda (hash-algo)
           (let ((file (add-to-store %store "guix.scm" #f hash-algo file)))
             (and (direct-store-path? file)
                  (bytevector=? (call-with-input-file file get-bytevector-all)
                                content)
                  hash-algo)))
         '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256"))))

(test-equal "add-data-to-store"
  #vu8(1 2 3 4 5)
  (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5))
    get-bytevector-all))

(test-assert "valid-path? live"
  (let ((p (add-text-to-store %store "hello" "hello, world")))
    (valid-path? %store p)))

(test-assert "valid-path? false"
  (not (valid-path? %store
                    (string-append (%store-prefix) "/"
                                   (make-string 32 #\e) "-foobar"))))

(test-equal "with-store, multiple values"        ;<https://bugs.gnu.org/42912>
  '(1 2 3)
  (call-with-values
      (lambda ()
        (with-store s
          (add-text-to-store s "foo" "bar")
          (values 1 2 3)))
    list))

(test-assert "valid-path? error"
  (with-store s
    (guard (c ((store-protocol-error? c) #t))
      (valid-path? s "foo")
      #f)))

(test-assert "valid-path? recovery"
  ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
  ;; close the connection after receiving a 'valid-path?' RPC with a non-store
  ;; file name.  See
  ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
  ;; details.
  (with-store s
    (let-syntax ((true-if-error (syntax-rules ()
                                  ((_ exp)
                                   (guard (c ((store-protocol-error? c) #t))
                                     exp #f)))))
      (and (true-if-error (valid-path? s "foo"))
           (true-if-error (valid-path? s "bar"))
           (true-if-error (valid-path? s "baz"))
           (true-if-error (valid-path? s "chbouib"))
           (valid-path? s (add-text-to-store s "valid" "yeah"))))))

(test-assert "hash-part->path"
  (let ((p (add-text-to-store %store "hello" "hello, world")))
    (equal? (hash-part->path %store (store-path-hash-part p))
            p)))

(test-assert "dead-paths"
  (let ((p (add-text-to-store %store "random-text" (random-text))))
    (->bool (member p (dead-paths %store)))))

;; FIXME: Find a test for `live-paths'.
;;
;; (test-assert "temporary root is in live-paths"
;;   (let* ((p1 (add-text-to-store %store "random-text"
;;                                 (random-text) '()))
;;          (b  (add-text-to-store %store "link-builder"
;;                                 (format #f "echo ~a > $out" p1)
;;                                 '()))
;;          (d1 (derivation %store "link"
;;                          "/bin/sh" `("-e" ,b)
;;                          #:inputs `((,b) (,p1))))
;;          (p2 (derivation->output-path d1)))
;;     (and (add-temp-root %store p2)
;;          (build-derivations %store (list d1))
;;          (valid-path? %store p1)
;;          (member (pk p2) (live-paths %store)))))

(test-assert "add-indirect-root and find-roots"
  (call-with-temporary-directory
   (lambda (directory)
     (let* ((item (add-text-to-store %store "something" (random-text)))
            (root (string-append directory "/gc-root")))
       (symlink item root)
       (add-indirect-root %store root)
       (let ((result (member (cons root item) (find-roots %store))))
         (delete-file root)
         result)))))

(test-assert "permanent root"
  (let* ((p  (with-store store
               (let ((p (add-text-to-store store "random-text"
                                           (random-text))))
                 (add-permanent-root p)
                 (add-permanent-root p)           ; should not throw
                 p))))
    (and (member p (live-paths %store))
         (begin
           (remove-permanent-root p)
           (->bool (member p (dead-paths %store)))))))

(test-assert "dead path can be explicitly collected"
  (let ((p (add-text-to-store %store "random-text"
                              (random-text) '())))
    (let-values (((paths freed) (delete-paths %store (list p))))
      (and (equal? paths (list p))
           ;; XXX: On some file systems (notably Btrfs), freed
           ;; may return 0.  See <https://bugs.gnu.org/29363>.
           ;;(> freed 0)
           (not (file-exists? p))))))

(test-assert "add-text-to-store/add-to-store vs. delete-paths"
  ;; Before, 'add-text-to-store' and 'add-to-store' would return the same
  ;; store item without noticing that it is no longer valid.
  (with-store store
    (let* ((text    (random-text))
           (file    (search-path %load-path "guix.scm"))
           (path1   (add-text-to-store store "delete-me" text))
           (path2   (add-to-store store "delete-me" #t "sha256" file))
           (deleted (delete-paths store (list path1 path2))))
      (and (string=? path1 (add-text-to-store store "delete-me" text))
           (string=? path2 (add-to-store store "delete-me" #t "sha256" file))
           (lset= string=? deleted (list path1 path2))
           (valid-path? store path1)
           (valid-path? store path2)
           (file-exists? path1)
           (file-exists? path2)))))

(test-equal "add-file-tree-to-store"
  `(42
    ("." directory #t)
    ("./bar" directory #t)
    ("./foo" directory #t)
    ("./foo/a" regular "file a")
    ("./foo/b" symlink "a")
    ("./foo/c" directory #t)
    ("./foo/c/p" regular "file p")
    ("./foo/c/q" directory #t)
    ("./foo/c/q/x" regular
     ,(string-append "#!" %shell "\nexit 42"))
    ("./foo/c/q/y" symlink "..")
    ("./foo/c/q/z" directory #t))
  (let* ((tree  `("file-tree" directory
                  ("foo" directory
                   ("a" regular (data "file a"))
                   ("b" symlink "a")
                   ("c" directory
                    ("p" regular (data ,(string->utf8 "file p")))
                    ("q" directory
                     ("x" executable
                      (data ,(string-append "#!" %shell "\nexit 42")))
                     ("y" symlink "..")
                     ("z" directory))))
                  ("bar" directory)))
         (result (add-file-tree-to-store %store tree)))
    (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
          (with-directory-excursion result
            (map (lambda (file)
                   (let ((type (stat:type (lstat file))))
                     `(,file ,type
                             ,(match type
                                ((or 'regular 'executable)
                                 (call-with-input-file file
                                   get-string-all))
                                ('symlink (readlink file))
                                ('directory #t)))))
                 (find-files "." #:directories? #t))))))

(test-equal "add-file-tree-to-store, flat"
  "Hello, world!"
  (let* ((tree   `("flat-file" regular (data "Hello, world!")))
         (result (add-file-tree-to-store %store tree)))
    (and (file-exists? result)
         (call-with-input-file result get-string-all))))

(test-assert "references"
  (let* ((t1 (add-text-to-store %store "random1"
                                (random-text)))
         (t2 (add-text-to-store %store "random2"
                                (random-text) (list t1))))
    (and (equal? (list t1) (references %store t2))
         (equal? (list t2) (referrers %store t1))
         (null? (references %store t1))
         (null? (referrers %store t2)))))

(test-equal "substitutable-path-info when substitutes are turned off"
  '()
  (with-store s
    (set-build-options s #:use-substitutes? #f)
    (let* ((b  (add-to-store s "bash" #t "sha256"
                             (search-bootstrap-binary "bash"
                                                      (%current-system))))
           (d  (derivation s "the-thing" b '("--version")
                           #:inputs `((,b))))
           (o  (derivation->output-path d)))
      (with-derivation-narinfo d
        (substitutable-path-info s (list o))))))

(test-equal "substitutable-paths when substitutes are turned off"
  '()
  (with-store s
    (set-build-options s #:use-substitutes? #f)
    (let* ((b  (add-to-store s "bash" #t "sha256"
                             (search-bootstrap-binary "bash"
                                                      (%current-system))))
           (d  (derivation s "the-thing" b '("--version")
                           #:inputs `((,b))))
           (o  (derivation->output-path d)))
      (with-derivation-narinfo d
        (substitutable-paths s (list o))))))

(test-assert "requisites"
  (let* ((t1 (add-text-to-store %store "random1"
                                (random-text) '()))
         (t2 (add-text-to-store %store "random2"
                                (random-text) (list t1)))
         (t3 (add-text-to-store %store "random3"
                                (random-text) (list t2)))
         (t4 (add-text-to-store %store "random4"
                                (random-text) (list t1 t3))))
    (define (same? x y)
      (and (= (length x) (length y))
           (lset= equal? x y)))

    (and (same? (requisites %store (list t1)) (list t1))
         (same? (requisites %store (list t2)) (list t1 t2))
         (same? (requisites %store (list t3)) (list t1 t2 t3))
         (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
         (same? (requisites %store (list t1 t2 t3 t4))
                (list t1 t2 t3 t4)))))

(test-assert "derivers"
  (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s (add-to-store %store "bash" #t "sha256"
                          (search-bootstrap-binary "bash"
                                                   (%current-system))))
         (d (derivation %store "the-thing"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s))))
         (o (derivation->output-path d)))
    (and (build-derivations %store (list d))
         (equal? (query-derivation-outputs %store (derivation-file-name d))
                 (list o))
         (equal? (valid-derivers %store o)
                 (list (derivation-file-name d))))))

(test-equal "with-build-handler"
  'success
  (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s  (add-to-store %store "bash" #t "sha256"
                           (search-bootstrap-binary "bash"
                                                    (%current-system))))
         (d1 (derivation %store "the-thing"
                         s `("-e" ,b)
                         #:env-vars `(("foo" . ,(random-text)))
                         #:sources (list b s)))
         (d2 (derivation %store "the-thing"
                         s `("-e" ,b)
                         #:env-vars `(("foo" . ,(random-text))
                                      ("bar" . "baz"))
                         #:sources (list b s)))
         (o1 (derivation->output-path d1))
         (o2 (derivation->output-path d2)))
    (with-build-handler
        (let ((counter 0))
          (lambda (continue store things mode)
            (match things
              ((drv)
               (set! counter (+ 1 counter))
               (if (string=? drv (derivation-file-name d1))
                   (continue #t)
                   (and (string=? drv (derivation-file-name d2))
                        (= counter 2)
                        'success))))))
      (build-derivations %store (list d1))
      (build-derivations %store (list d2))
      'fail)))

(test-equal "with-build-handler + with-store"
  'success
  ;; Check that STORE remains valid when the build handler invokes CONTINUE,
  ;; even though 'with-build-handler' is outside the dynamic extent of
  ;; 'with-store'.
  (with-build-handler (lambda (continue store things mode)
                        (match things
                          ((drv)
                           (and (string-suffix? "thingie.drv" drv)
                                (not (port-closed?
                                      (store-connection-socket store)))
                                (continue #t)))))
    (with-store store
      (let* ((b (add-text-to-store store "build" "echo $foo > $out" '()))
             (s (add-to-store store "bash" #t "sha256"
                              (search-bootstrap-binary "bash"
                                                       (%current-system))))
             (d (derivation store "thingie"
                            s `("-e" ,b)
                            #:env-vars `(("foo" . ,(random-text)))
                            #:sources (list b s))))
        (build-derivations store (list d))

        ;; Here STORE's socket should still be open.
        (and (valid-path? store (derivation->output-path d))
             'success)))))

(test-assert "map/accumulate-builds"
  (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s  (add-to-store %store "bash" #t "sha256"
                           (search-bootstrap-binary "bash"
                                                    (%current-system))))
         (d1 (derivation %store "the-thing"
                         s `("-e" ,b)
                         #:env-vars `(("foo" . ,(random-text)))
                         #:sources (list b s)))
         (d2 (derivation %store "the-thing"
                         s `("-e" ,b)
                         #:env-vars `(("foo" . ,(random-text))
                                      ("bar" . "baz"))
                         #:sources (list b s))))
    (with-build-handler (lambda (continue store things mode)
                          (equal? (map derivation-file-name (list d1 d2))
                                  things))
      (map/accumulate-builds %store
                             (lambda (drv)
                               (build-derivations %store (list drv))
                               (add-to-store %store "content-addressed"
                                             #t "sha256"
                                             (derivation->output-path drv)))
                             (list d1 d2)))))

(test-assert "mapm/accumulate-builds"
  (let* ((d1 (run-with-store %store
               (gexp->derivation "foo" #~(mkdir #$output))))
         (d2 (run-with-store %store
               (gexp->derivation "bar" #~(mkdir #$output)))))
    (with-build-handler (lambda (continue store things mode)
                          (equal? (map derivation-file-name (pk 'zz (list d1 d2)))
                                  (pk 'XX things)))
      (run-with-store %store
        (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))

(test-equal "mapm/accumulate-builds, %current-target-system"
  (make-list 2 '("i586-pc-gnu" "i586-pc-gnu"))
  ;; Both the 'mapm' and 'mapm/accumulate-builds' procedures should see the
  ;; right #:target.
  (run-with-store %store
    (mlet %store-monad ((lst1 (mapm %store-monad
                                    (lambda _
                                      (current-target-system))
                                    '(a b)))
                        (lst2 (mapm/accumulate-builds
                               (lambda _
                                 (current-target-system))
                               '(a b))))
      (return (list lst1 lst2)))
    #:system system
    #:target "i586-pc-gnu"))

(test-assert "topologically-sorted, one item"
  (let* ((a (add-text-to-store %store "a" "a"))
         (b (add-text-to-store %store "b" "b" (list a)))
         (c (add-text-to-store %store "c" "c" (list b)))
         (d (add-text-to-store %store "d" "d" (list c)))
         (s (topologically-sorted %store (list d))))
    (equal? s (list a b c d))))

(test-assert "topologically-sorted, several items"
  (let* ((a  (add-text-to-store %store "a" "a"))
         (b  (add-text-to-store %store "b" "b" (list a)))
         (c  (add-text-to-store %store "c" "c" (list b)))
         (d  (add-text-to-store %store "d" "d" (list c)))
         (s1 (topologically-sorted %store (list d a c b)))
         (s2 (topologically-sorted %store (list b d c a b d))))
    (equal? s1 s2 (list a b c d))))

(test-assert "topologically-sorted, more difficult"
  (let* ((a  (add-text-to-store %store "a" "a"))
         (b  (add-text-to-store %store "b" "b" (list a)))
         (c  (add-text-to-store %store "c" "c" (list b)))
         (d  (add-text-to-store %store "d" "d" (list c)))
         (w  (add-text-to-store %store "w" "w"))
         (x  (add-text-to-store %store "x" "x" (list w)))
         (y  (add-text-to-store %store "y" "y" (list x d)))
         (s1 (topologically-sorted %store (list y)))
         (s2 (topologically-sorted %store (list c y)))
         (s3 (topologically-sorted %store (cons y (references %store y)))))
    ;; The order in which 'references' returns the references of Y is
    ;; unspecified, so accommodate.
    (let* ((x-then-d? (equal? (references %store y) (list x d))))
      (and (equal? s1
                   (if x-then-d?
                       (list w x a b c d y)
                       (list a b c d w x y)))
           (equal? s2
                   (if x-then-d?
                       (list a b c w x d y)
                       (list a b c d w x y)))
           (lset= string=? s1 s3)))))

(test-assert "current-build-output-port, UTF-8"
  ;; Are UTF-8 strings in the build log properly interpreted?
  (string-contains
   (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
     (call-with-output-string
      (lambda (port)
        (parameterize ((current-build-output-port port))
          (let* ((s "Here’s a Greek letter: λ.")
                 (d (build-expression->derivation
                     %store "foo" `(display ,s)
                     #:guile-for-build
                     (package-derivation s %bootstrap-guile (%current-system)))))
            (guard (c ((store-protocol-error? c) #t))
              (build-derivations %store (list d))))))))
   "Here’s a Greek letter: λ."))

(test-assert "current-build-output-port, UTF-8 + garbage"
  ;; What about a mixture of UTF-8 + garbage?
  (string-contains
   (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
     (call-with-output-string
      (lambda (port)
        (parameterize ((current-build-output-port port))
          (let ((d (build-expression->derivation
                    %store "foo"
                    `(begin
                       (use-modules (rnrs io ports))
                       (display "garbage: ")
                       (put-bytevector (current-output-port) #vu8(128))
                       (display "lambda: λ\n"))
                     #:guile-for-build
                     (package-derivation %store %bootstrap-guile))))
            (guard (c ((store-protocol-error? c) #t))
              (build-derivations %store (list d))))))))
   "garbage: �lambda: λ"))

(test-assert "log-file, derivation"
  (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s (add-to-store %store "bash" #t "sha256"
                          (search-bootstrap-binary "bash"
                                                   (%current-system))))
         (d (derivation %store "the-thing"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s)))))
    (and (build-derivations %store (list d))
         (file-exists? (pk (log-file %store (derivation-file-name d)))))))

(test-assert "log-file, output file name"
  (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s (add-to-store %store "bash" #t "sha256"
                          (search-bootstrap-binary "bash"
                                                   (%current-system))))
         (d (derivation %store "the-thing"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s))))
         (o (derivation->output-path d)))
    (and (build-derivations %store (list d))
         (file-exists? (pk (log-file %store o)))
         (string=? (log-file %store (derivation-file-name d))
                   (log-file %store o)))))

(test-assert "no substitutes"
  (with-store s
    (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
           (d2 (package-derivation s %bootstrap-glibc (%current-system)))
           (o  (map derivation->output-path (list d1 d2))))
      (set-build-options s #:use-substitutes? #f)
      (and (not (has-substitutes? s (derivation-file-name d1)))
           (not (has-substitutes? s (derivation-file-name d2)))
           (null? (substitutable-paths s o))
           (null? (substitutable-path-info s o))))))

(test-assert "build-things with output path"
  (with-store s
    (let* ((c   (random-text))                    ;contents of the output
           (d   (build-expression->derivation
                 s "substitute-me"
                 `(call-with-output-file %output
                    (lambda (p)
                      (display ,c p)))
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      (set-build-options s #:use-substitutes? #f)

      ;; Pass 'build-things' the output file name, O.  However, since there
      ;; are no substitutes for O, it will just do nothing.
      (build-things s (list o))
      (not (valid-path? s o)))))

(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))

(test-assert "substitute query"
  (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 'guix substitute'.
      (with-derivation-narinfo d
        ;; Remove entry from the local cache.
        (false-if-exception
         (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
                                                 "/guix/substitute")))

        ;; Make sure 'guix substitute' correctly communicates the above
        ;; data.
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)
             (equal? (list o) (substitutable-paths s (list o)))
             (match (pk 'spi (substitutable-path-info s (list o)))
               (((? substitutable? s))
                (and (string=? (substitutable-deriver s)
                               (derivation-file-name d))
                     (null? (substitutable-references s))
                     (equal? (substitutable-nar-size s) 1234)))))))))

(test-assert "substitute query, alternating URLs"
  (let* ((d (with-store s
              (package-derivation s %bootstrap-guile (%current-system))))
         (o (derivation->output-path d)))
    (with-derivation-narinfo d
      ;; Remove entry from the local cache.
      (false-if-exception
       (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
                                               "/guix/substitute")))

      ;; Note: We reconnect to the daemon to force a new instance of 'guix
      ;; substitute' to be used; otherwise the #:substitute-urls of
      ;; 'set-build-options' would have no effect.

      (and (with-store s                        ;the right substitute URL
             (set-build-options s #:use-substitutes? #t
                                #:substitute-urls (%test-substitute-urls))
             (has-substitutes? s o))
           (with-store s                        ;the wrong one
             (set-build-options s #:use-substitutes? #t
                                #:substitute-urls (list
                                                   "http://does-not-exist"))
             (not (has-substitutes? s o)))
           (with-store s                        ;the right one again
             (set-build-options s #:use-substitutes? #t
                                #:substitute-urls (%test-substitute-urls))
             (has-substitutes? s o))
           (with-store s                        ;empty list of URLs
             (set-build-options s #:use-substitutes? #t
                                #:substitute-urls '())
             (not (has-substitutes? s o)))))))

(test-assert "substitute"
  (with-store s
    (let* ((c   (random-text))                     ; contents of the output
           (d   (build-expression->derivation
                 s "substitute-me"
                 `(call-with-output-file %output
                    (lambda (p)
                      (exit 1)                     ; would actually fail
                      (display ,c p)))
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      (with-derivation-substitute d c
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)
             (build-derivations s (list d))
             (canonical-file? o)
             (equal? c (call-with-input-file o get-string-all)))))))

(test-assert "substitute, deduplication"
  (with-store s
    (let* ((c   (random-text))                     ; contents of the output
           (g   (package-derivation s %bootstrap-guile))
           (d1  (build-expression->derivation s "substitute-me"
                                              `(begin ,c (exit 1))
                                              #:guile-for-build g))
           (d2  (build-expression->derivation s "build-me"
                                              `(call-with-output-file %output
                                                 (lambda (p)
                                                   (display ,c p)))
                                              #:guile-for-build g))
           (o1  (derivation->output-path d1))
           (o2  (derivation->output-path d2)))
      (with-derivation-substitute d1 c
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o1)
             (build-derivations s (list d2))      ;build
             (build-derivations s (list d1))      ;substitute
             (canonical-file? o1)
             (equal? c (call-with-input-file o1 get-string-all))
             (= (stat:ino (stat o1)) (stat:ino (stat o2))))))))

(test-assert "substitute + build-things with output path"
  (with-store s
    (let* ((c   (random-text))                    ;contents of the output
           (d   (build-expression->derivation
                 s "substitute-me"
                 `(call-with-output-file %output
                    (lambda (p)
                      (exit 1)                    ;would actually fail
                      (display ,c p)))
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      (with-derivation-substitute d c
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)
             (build-things s (list o))            ;give the output path
             (valid-path? s o)
             (canonical-file? o)
             (equal? c (call-with-input-file o get-string-all)))))))

(test-assert "substitute + build-things with specific output"
  (with-store s
    (let* ((c   (random-text))                    ;contents of the output
           (d   (build-expression->derivation
                 s "substitute-me" `(begin ,c (exit 1)) ;would fail
                 #:outputs '("out" "one" "two")
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      (with-derivation-substitute d c
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)

             ;; Ask for nothing but the "out" output of D.
             (build-things s `((,(derivation-file-name d) . "out")))

             (valid-path? s o)
             (canonical-file? o)
             (equal? c (call-with-input-file o get-string-all)))))))

(test-assert "substitute, corrupt output hash"
  ;; Tweak the substituter into installing a substitute whose hash doesn't
  ;; match the one announced in the narinfo.  The daemon must notice this and
  ;; raise an error.
  (with-store s
    (let* ((c   "hello, world")                    ; contents of the output
           (d   (build-expression->derivation
                 s "corrupt-substitute"
                 `(mkdir %output)
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      (with-derivation-substitute d c
        (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C

        ;; Make sure we use 'guix substitute'.
        (set-build-options s
                           #:use-substitutes? #t
                           #:fallback? #f
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)
             (guard (c ((store-protocol-error? c)
                        ;; XXX: the daemon writes "hash mismatch in downloaded
                        ;; path", but the actual error returned to the client
                        ;; doesn't mention that.
                        (pk 'corrupt c)
                        (not (zero? (store-protocol-error-status c)))))
               (build-derivations s (list d))
               #f))))))

(test-assert "substitute, corrupt output hash, build trace"
  ;; Likewise, and check the build trace.
  (with-store s
    (let* ((c   "hello, world")                   ; contents of the output
           (d   (build-expression->derivation
                 s "corrupt-substitute"
                 `(mkdir %output)
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      ;; Make sure we use 'guix substitute'.
      (set-build-options s
                         #:print-build-trace #t
                         #:use-substitutes? #t
                         #:fallback? #f
                         #:substitute-urls (%test-substitute-urls))

      (with-derivation-substitute d c
        (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C

        (define output
          (call-with-output-string
            (lambda (port)
              (parameterize ((current-build-output-port port))
                (guard (c ((store-protocol-error? c) #t))
                  (build-derivations s (list d))
                  #f)))))

        (define actual-hash
          (let-values (((port get-hash)
                        (gcrypt:open-hash-port
                         (gcrypt:hash-algorithm gcrypt:sha256))))
            (write-file-tree "foo" port
                             #:file-type+size
                             (lambda _
                               (values 'regular (string-length c)))
                             #:file-port
                             (lambda _
                               (open-input-string c)))
            (close-port port)
            (bytevector->nix-base32-string (get-hash))))

        (define expected-hash
          (bytevector->nix-base32-string (make-bytevector 32 0)))

        (define mismatch
          (string-append "@ hash-mismatch " o " sha256 "
                         expected-hash " " actual-hash "\n"))

        (define failure
          (string-append "@ substituter-failed " o))

        (and (string-contains output mismatch)
             (string-contains output failure))))))

(test-assert "substitute --fallback"
  (with-store s
    (let* ((t   (random-text))                    ; contents of the output
           (d   (build-expression->derivation
                 s "substitute-me-not"
                 `(call-with-output-file %output
                    (lambda (p)
                      (display ,t p)))
                 #:guile-for-build
                 (package-derivation s %bootstrap-guile (%current-system))))
           (o   (derivation->output-path d)))
      ;; Create fake substituter data, to be read by 'guix substitute'.
      (with-derivation-narinfo d
        ;; Make sure we use 'guix substitute'.
        (set-build-options s #:use-substitutes? #t
                           #:substitute-urls (%test-substitute-urls))
        (and (has-substitutes? s o)
             (guard (c ((store-protocol-error? c)
                        ;; The substituter failed as expected.  Now make
                        ;; sure that #:fallback? #t works correctly.
                        (set-build-options s
                                           #:use-substitutes? #t
                                           #:substitute-urls
                                             (%test-substitute-urls)
                                           #:fallback? #t)
                        (and (build-derivations s (list d))
                             (equal? t (call-with-input-file o
                                         get-string-all)))))
               ;; Should fail.
               (build-derivations s (list d))
               #f))))))

(test-assert "export/import several paths"
  (let* ((texts (unfold (cut >= <> 10)
                        (lambda _ (random-text))
                        1+
                        0))
         (files (map (cut add-text-to-store %store "text" <>) texts))
         (dump  (call-with-bytevector-output-port
                 (cut export-paths %store files <>))))
    (delete-paths %store files)
    (and (every (negate file-exists?) files)
         (let* ((source   (open-bytevector-input-port dump))
                (imported (import-paths %store source)))
           (and (equal? imported files)
                (every file-exists? files)
                (equal? texts
                        (map (lambda (file)
                               (call-with-input-file file
                                 get-string-all))
                             files)))))))

(test-assert "export/import paths, ensure topological order"
  (let* ((file0 (add-text-to-store %store "baz" (random-text)))
         (file1 (add-text-to-store %store "foo" (random-text)
                                   (list file0)))
         (file2 (add-text-to-store %store "bar" (random-text)
                                   (list file1)))
         (files (list file1 file2))
         (dump1 (call-with-bytevector-output-port
                 (cute export-paths %store (list file1 file2) <>)))
         (dump2 (call-with-bytevector-output-port
                 (cute export-paths %store (list file2 file1) <>))))
    (delete-paths %store files)
    (and (every (negate file-exists?) files)
         (bytevector=? dump1 dump2)
         (let* ((source   (open-bytevector-input-port dump1))
                (imported (import-paths %store source)))
           ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
           (and (equal? imported (list file1 file2))
                (every file-exists? files)
                (equal? (list file0) (references %store file1))
                (equal? (list file1) (references %store file2)))))))

(test-assert "export/import incomplete"
  (let* ((file0 (add-text-to-store %store "baz" (random-text)))
         (file1 (add-text-to-store %store "foo" (random-text)
                                   (list file0)))
         (file2 (add-text-to-store %store "bar" (random-text)
                                   (list file1)))
         (dump  (call-with-bytevector-output-port
                 (cute export-paths %store (list file2) <>))))
    (delete-paths %store (list file0 file1 file2))
    (guard (c ((store-protocol-error? c)
               (and (not (zero? (store-protocol-error-status c)))
                    (string-contains (store-protocol-error-message c)
                                     "not valid"))))
      ;; Here we get an exception because DUMP does not include FILE0 and
      ;; FILE1, which are dependencies of FILE2.
      (import-paths %store (open-bytevector-input-port dump)))))

(test-assert "export/import recursive"
  (let* ((file0 (add-text-to-store %store "baz" (random-text)))
         (file1 (add-text-to-store %store "foo" (random-text)
                                   (list file0)))
         (file2 (add-text-to-store %store "bar" (random-text)
                                   (list file1)))
         (dump  (call-with-bytevector-output-port
                 (cute export-paths %store (list file2) <>
                       #:recursive? #t))))
    (delete-paths %store (list file0 file1 file2))
    (let ((imported (import-paths %store (open-bytevector-input-port dump))))
      (and (equal? imported (list file0 file1 file2))
           (every file-exists? (list file0 file1 file2))
           (equal? (list file0) (references %store file1))
           (equal? (list file1) (references %store file2))))))

(test-assert "write-file & export-path yield the same result"
  ;; Here we compare 'write-file' and the daemon's own implementation.
  ;; 'write-file' is the reference because we know it sorts file
  ;; deterministically.  Conversely, the daemon uses 'readdir' and the entries
  ;; currently happen to be sorted as a side-effect of some unrelated
  ;; operation (search for 'unhacked' in archive.cc.)  Make sure we detect any
  ;; changes there.
  (run-with-store %store
    (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
                         (out1 -> (derivation->output-path drv1))
                         (data -> (unfold (cut >= <> 26)
                                          (lambda (i)
                                            (random-bytevector 128))
                                          1+ 0))
                         (build
                          -> #~(begin
                                 (use-modules (rnrs io ports) (srfi srfi-1))
                                 (let ()
                                   (define letters
                                     (map (lambda (i)
                                            (string
                                             (integer->char
                                              (+ i (char->integer #\a)))))
                                          (iota 26)))
                                   (define (touch file data)
                                     (call-with-output-file file
                                       (lambda (port)
                                         (put-bytevector port data))))

                                   (mkdir #$output)
                                   (chdir #$output)

                                   ;; The files must be different so they have
                                   ;; different inode numbers, and the inode
                                   ;; order must differ from the lexicographic
                                   ;; order.
                                   (for-each touch
                                             (append (drop letters 10)
                                                     (take letters 10))
                                             (list #$@data))
                                   #t)))
                         (drv2 (gexp->derivation "bunch" build))
                         (out2 -> (derivation->output-path drv2))
                         (item-info -> (store-lift query-path-info)))
      (mbegin %store-monad
        (built-derivations (list drv1 drv2))
        (foldm %store-monad
               (lambda (item result)
                 (define ref-hash
                   (let-values (((port get) (gcrypt:open-sha256-port)))
                     (write-file item port)
                     (close-port port)
                     (get)))

                 ;; 'query-path-info' returns a hash produced by using the
                 ;; daemon's C++ 'dump' function, which is the implementation
                 ;; under test.
                 (>>= (item-info item)
                      (lambda (info)
                        (return
                         (and result
                              (bytevector=? (path-info-hash info) ref-hash))))))
               #t
               (list out1 out2))))
    #:guile-for-build (%guile-for-build)))

(test-assert "import not signed"
  (let* ((text (random-text))
         (file (add-file-tree-to-store %store
                                       `("tree" directory
                                         ("text" regular (data ,text))
                                         ("link" symlink "text"))))
         (dump (call-with-bytevector-output-port
                (lambda (port)
                  (write-int 1 port)              ;start

                  (write-file file port)          ;contents
                  (write-int #x4558494e port)     ;%export-magic
                  (write-string file port)        ;store item
                  (write-string-list '() port)    ;references
                  (write-string "" port)          ;deriver
                  (write-int 0 port)              ;not signed

                  (write-int 0 port)))))          ;done

    ;; Ensure 'import-paths' raises an exception.
    (guard (c ((store-protocol-error? c)
               (and (not (zero? (store-protocol-error-status c)))
                    (string-contains (store-protocol-error-message c)
                                     "lacks a signature"))))
      (let* ((source   (open-bytevector-input-port dump))
             (imported (import-paths %store source)))
        (pk 'unsigned-imported imported)
        #f))))

(test-assert "import signed by unauthorized key"
  (let* ((text (random-text))
         (file (add-file-tree-to-store %store
                                       `("tree" directory
                                         ("text" regular (data ,text))
                                         ("link" symlink "text"))))
         (key  (gcrypt:generate-key
                (gcrypt:string->canonical-sexp
                 "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))")))
         (dump (call-with-bytevector-output-port
                (lambda (port)
                  (write-int 1 port)              ;start

                  (write-file file port)          ;contents
                  (write-int #x4558494e port)     ;%export-magic
                  (write-string file port)        ;store item
                  (write-string-list '() port)    ;references
                  (write-string "" port)          ;deriver
                  (write-int 1 port)              ;signed
                  (write-string (gcrypt:canonical-sexp->string
                                 (signature-sexp
                                  (gcrypt:bytevector->hash-data
                                   (gcrypt:sha256 #vu8(0 1 2))
                                   #:key-type 'ecc)
                                  (gcrypt:find-sexp-token key 'private-key)
                                  (gcrypt:find-sexp-token key 'public-key)))
                                port)

                  (write-int 0 port)))))          ;done

    ;; Ensure 'import-paths' raises an exception.
    (guard (c ((store-protocol-error? c)
               (and (not (zero? (store-protocol-error-status c)))
                    (string-contains (store-protocol-error-message c)
                                     "unauthorized public key"))))
      (let* ((source   (open-bytevector-input-port dump))
             (imported (import-paths %store source)))
        (pk 'unauthorized-imported imported)
        #f))))

(test-assert "import corrupt path"
  (let* ((text (random-text))
         (file (add-text-to-store %store "text" text))
         (dump (call-with-bytevector-output-port
                (cut export-paths %store (list file) <>))))
    (delete-paths %store (list file))

    ;; Flip a bit in the stream's payload.  INDEX here falls in the middle of
    ;; the file contents in DUMP, regardless of the store prefix.
    (let* ((index #x70)
           (byte  (bytevector-u8-ref dump index)))
      (bytevector-u8-set! dump index (logxor #xff byte)))

    (and (not (file-exists? file))
         (guard (c ((store-protocol-error? c)
                    (pk 'c c)
                    (and (not (zero? (store-protocol-error-status c)))
                         (string-contains (store-protocol-error-message c)
                                          "corrupt"))))
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (import-paths %store source)))
             (pk 'corrupt-imported imported)
             #f)))))

(test-assert "verify-store"
  (let* ((text  (random-text))
         (file1 (add-text-to-store %store "foo" text))
         (file2 (add-text-to-store %store "bar" (random-text)
                                   (list file1))))
    (and (pk 'verify1 (verify-store %store))    ;hopefully OK ;
         (begin
           (delete-file file1)
           (not (pk 'verify2 (verify-store %store)))) ;bad! ;
         (begin
           ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
           ;; without actually creating the file. ;
           (call-with-output-file file1
             (lambda (port)
               (display text port)))
           (pk 'verify3 (verify-store %store)))))) ;OK again

(test-assert "verify-store + check-contents"
  ;; XXX: This test is I/O intensive.
  (with-store s
    (let* ((text (random-text))
           (drv  (build-expression->derivation
                  s "corrupt"
                  `(let ((out (assoc-ref %outputs "out")))
                     (call-with-output-file out
                       (lambda (port)
                         (display ,text port)))
                     #t)
                  #:guile-for-build
                  (package-derivation s %bootstrap-guile (%current-system))))
           (file (derivation->output-path drv)))
      (with-derivation-substitute drv text
        (and (build-derivations s (list drv))
             (verify-store s #:check-contents? #t) ;should be OK
             (begin
               (chmod file #o644)
               (call-with-output-file file
                 (lambda (port)
                   (display "corrupt!" port)))
               #t)

             ;; Make sure the corruption is detected.  We don't test repairing
             ;; because only "trusted" users are allowed to do it, but we
             ;; don't expose that notion of trusted users that nix-daemon
             ;; supports because it seems dubious and redundant with what the
             ;; OS provides (in Nix "trusted" users have additional
             ;; privileges, such as overriding the set of substitute URLs, but
             ;; we instead want to allow anyone to modify them, provided
             ;; substitutes are signed by a root-approved key.)
             (not (verify-store s #:check-contents? #t))

             ;; Delete the corrupt item to leave the store in a clean state.
             (delete-paths s (list file)))))))

(test-assert "build-things, check mode"
  (with-store store
    (call-with-temporary-output-file
     (lambda (entropy entropy-port)
       (write (random-text) entropy-port)
       (force-output entropy-port)
       (let* ((drv  (build-expression->derivation
                     store "non-deterministic"
                     `(begin
                        (use-modules (rnrs io ports))
                        (let ((out (assoc-ref %outputs "out")))
                          (call-with-output-file out
                            (lambda (port)
                              ;; Rely on the fact that tests do not use the
                              ;; chroot, and thus ENTROPY is readable.
                              (display (call-with-input-file ,entropy
                                         get-string-all)
                                       port)))
                          #t))
                     #:guile-for-build
                     (package-derivation store %bootstrap-guile (%current-system))))
              (file (derivation->output-path drv)))
         (and (build-things store (list (derivation-file-name drv)))
              (begin
                (write (random-text) entropy-port)
                (force-output entropy-port)
                (guard (c ((store-protocol-error? c)
                           (pk 'determinism-exception c)
                           (and (not (zero? (store-protocol-error-status c)))
                                (string-contains (store-protocol-error-message c)
                                                 "deterministic"))))
                  ;; This one will produce a different result.  Since we're in
                  ;; 'check' mode, this must fail.
                  (build-things store (list (derivation-file-name drv))
                                (build-mode check))
                  #f))))))))

(test-assert "build-succeeded trace in check mode"
  (string-contains
   (call-with-output-string
     (lambda (port)
       (let ((d (build-expression->derivation
                 %store "foo" '(mkdir (assoc-ref %outputs "out"))
                 #:guile-for-build
                 (package-derivation %store %bootstrap-guile))))
         (build-derivations %store (list d))
         (parameterize ((current-build-output-port port))
           (build-derivations %store (list d) (build-mode check))))))
   "@ build-succeeded"))

(test-assert "build multiple times"
  (with-store store
    ;; Ask to build twice.
    (set-build-options store #:rounds 2 #:use-substitutes? #f)

    (call-with-temporary-output-file
     (lambda (entropy entropy-port)
       (write (random-text) entropy-port)
       (force-output entropy-port)
       (let* ((drv  (build-expression->derivation
                     store "non-deterministic"
                     `(begin
                        (use-modules (rnrs io ports))
                        (let ((out (assoc-ref %outputs "out")))
                          (call-with-output-file out
                            (lambda (port)
                              ;; Rely on the fact that tests do not use the
                              ;; chroot, and thus ENTROPY is accessible.
                              (display (call-with-input-file ,entropy
                                         get-string-all)
                                       port)
                              (call-with-output-file ,entropy
                                (lambda (port)
                                  (write 'foobar port)))))
                          #t))
                     #:guile-for-build
                     (package-derivation store %bootstrap-guile (%current-system))))
              (file (derivation->output-path drv)))
         (guard (c ((store-protocol-error? c)
                    (pk 'multiple-build c)
                    (and (not (zero? (store-protocol-error-status c)))
                         (string-contains (store-protocol-error-message c)
                                          "deterministic"))))
           ;; This one will produce a different result on the second run.
           (current-build-output-port (current-error-port))
           (build-things store (list (derivation-file-name drv)))
           #f))))))

(test-equal "store-lower"
  "Lowered."
  (let* ((add  (store-lower text-file))
         (file (add %store "foo" "Lowered.")))
    (call-with-input-file file get-string-all)))

(test-equal "current-system"
  "bar"
  (parameterize ((%current-system "frob"))
    (run-with-store %store
      (mbegin %store-monad
        (set-current-system "bar")
        (current-system))
      #:system "foo")))

(test-assert "query-path-info"
  (let* ((ref (add-text-to-store %store "ref" "foo"))
         (item (add-text-to-store %store "item" "bar" (list ref)))
         (info (query-path-info %store item)))
    (and (equal? (path-info-references info) (list ref))
         (equal? (path-info-hash info)
                 (gcrypt:sha256
                  (string->utf8
                   (call-with-output-string (cut write-file item <>))))))))

(test-assert "path-info-deriver"
  (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
         (s (add-to-store %store "bash" #t "sha256"
                          (search-bootstrap-binary "bash"
                                                   (%current-system))))
         (d (derivation %store "the-thing"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s))))
         (o (derivation->output-path d)))
    (and (build-derivations %store (list d))
         (not (path-info-deriver (query-path-info %store b)))
         (string=? (derivation-file-name d)
                   (path-info-deriver (query-path-info %store o))))))

(test-equal "build-cores"
  (list 0 42)
  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "echo $NIX_BUILD_CORES > $out"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv1   (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text)))))
           (drv2   (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text))))))
      (and (build-derivations store (list drv1))
           (begin
             (set-build-options store #:build-cores 42)
             (build-derivations store (list drv2)))
           (list (call-with-input-file (derivation->output-path drv1)
                   read)
                 (call-with-input-file (derivation->output-path drv2)
                   read))))))

(test-equal "multiplexed-build-output"
  '("Hello from first." "Hello from second.")
  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "echo Hello from $NAME.; echo > $out"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv1   (derivation store "one" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("NAME" . "first")
                                            ("x" . ,(random-text)))))
           (drv2   (derivation store "two" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("NAME" . "second")
                                            ("x" . ,(random-text))))))
      (set-build-options store
                         #:print-build-trace #t
                         #:multiplexed-build-output? #t
                         #:max-build-jobs 10)
      (let ((port (open-output-string)))
        ;; Send the build log to PORT.
        (parameterize ((current-build-output-port port))
          (build-derivations store (list drv1 drv2)))

        ;; Retrieve the build log; make sure it contains valid "@ build-log"
        ;; traces that allow us to retrieve each builder's output (we assume
        ;; there's exactly one "build-output" trace for each builder, which is
        ;; reasonable.)
        (let* ((log     (get-output-string port))
               (started (fold-matches
                         (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)")
                         log '() cons))
               (done    (fold-matches
                         (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)")
                         log '() cons))
               (output  (fold-matches
                         (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n")
                         log '() cons))
               (drv-pid (lambda (name)
                          (lambda (m)
                            (let ((drv (match:substring m 1))
                                  (pid (string->number
                                        (match:substring m 4))))
                              (and (string-suffix? name drv) pid)))))
               (pid-log (lambda (pid)
                          (lambda (m)
                            (let ((n   (string->number
                                        (match:substring m 1)))
                                  (len (string->number
                                        (match:substring m 2)))
                                  (str (match:substring m 3)))
                              (and (= pid n)
                                   (= (string-length str) (- len 1))
                                   str)))))
               (pid1    (any (drv-pid "one.drv") started))
               (pid2    (any (drv-pid "two.drv") started)))
          (list (any (pid-log pid1) output)
                (any (pid-log pid2) output)))))))

(test-end "store")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015, 2017, 2018, 2019, 2021 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 narinfo)
  #: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-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)
  #: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 ((current-error-port error-output)
                     (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 (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")
    (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 %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") <>))

        (%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")))

;; Never use file descriptor 4, unlike what happens when invoked by the
;; daemon.
(%reply-file-descriptor #f)

(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
    (with-input-from-string (string-append "substitute "
                                           (%store-prefix)
                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
                                           " foo\n")
      (lambda ()
        (guix-substitute "--substitute")))))

(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")
    (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"
    "no valid substitute"
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field
                                %narinfo
                                #:public-key %wrong-public-key)
                               "\n")
    (with-input-from-string (string-append "substitute "
                                           (%store-prefix)
                                           "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo"
                                           " foo\n")
      (lambda ()
        (guix-substitute "--substitute")))))

(test-equal "substitute, authorized key"
  '("Substitutable data." 1 #o444)
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field %narinfo))
    (dynamic-wind
      (const #t)
      (lambda ()
        (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:

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020, 2021 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-swh)
  #:use-module (guix swh)
  #:use-module (guix tests http)
  #:use-module (web response)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

;; Test the JSON mapping machinery used in (guix swh).

(define %origin
  "{ \"origin_visits_url\": \"/visits/42\",
     \"type\": \"git\",
     \"url\": \"http://example.org/guix.git\" }")

(define %visits
  ;; A single visit where 'snapshot_url' is null.
  ;; See <https://bugs.gnu.org/45615>.
  "[ {
    \"origin\": \"https://github.com/Genivia/ugrep\",
    \"visit\": 1,
    \"date\": \"2020-05-17T21:43:45.422977+00:00\",
    \"status\": \"ongoing\",
    \"snapshot\": null,
    \"metadata\": {},
    \"type\": \"git\",
    \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\",
    \"snapshot_url\": null
  } ]")

(define %directory-entries
  "[ { \"name\": \"one\",
       \"type\": \"regular\",
       \"length\": 123,
       \"dir_id\": 1 },
     { \"name\": \"two\",
       \"type\": \"regular\",
       \"length\": 456,
       \"dir_id\": 2 } ]")

(define-syntax-rule (with-json-result str exp ...)
  (with-http-server `((200 ,str))
    (parameterize ((%swh-base-url (%local-url)))
      exp ...)))

(test-begin "swh")

(test-equal "lookup-origin"
  (list "git" "http://example.org/guix.git")
  (with-json-result %origin
    (let ((origin (lookup-origin "http://example.org/guix.git")))
      (list (origin-type origin)
            (origin-url origin)))))

(test-equal "lookup-origin, not found"
  #f
  (with-http-server `((404 "Nope."))
    (parameterize ((%swh-base-url (%local-url)))
      (lookup-origin "http://example.org/whatever"))))

(test-equal "origin-visit, no snapshots"
  '("https://github.com/Genivia/ugrep"
    "2020-05-17T21:43:45Z"
    #f)                                      ;see <https://bugs.gnu.org/45615>
  (with-http-server `((200 ,%origin)
                      (200 ,%visits))
    (parameterize ((%swh-base-url (%local-url)))
      (let ((origin (lookup-origin "http://example.org/whatever")))
        (match (origin-visits origin)
          ((visit)
           (list (visit-origin visit)
                 (date->string (visit-date visit) "~4")
                 (visit-snapshot-url visit))))))))

(test-equal "lookup-directory"
  '(("one" 123) ("two" 456))
  (with-json-result %directory-entries
    (map (lambda (entry)
           (list (directory-entry-name entry)
                 (directory-entry-length entry)))
         (lookup-directory "123"))))

(test-equal "rate limit reached"
  3000000000
  (let ((too-many (build-response
                   #:code 429
                   #:reason-phrase "Too many requests"

                   ;; Pretend we've reached the limit and it'll be reset in
                   ;; June 2065.
                   #:headers '((x-ratelimit-remaining . "0")
                               (x-ratelimit-reset . "3000000000")))))
    (with-http-server `((,too-many "Too bad."))
      (parameterize ((%swh-base-url (%local-url)))
        (catch 'swh-error
          (lambda ()
            (lookup-origin "http://example.org/guix.git"))
          (lambda (key url method response)
            ;; Ensure the reset time was recorded.
            (@@ (guix swh) %general-rate-limit-reset-time)))))))

(test-assert "%allow-request? and request-rate-limit-reached?"
  ;; Here we test two things: that the rate limit set above is in effect and
  ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?'
  ;; returns true.
  (let* ((key (gensym "skip-request"))
         (skip-if-limit-reached
          (lambda (url method)
            (or (not (request-rate-limit-reached? url method))
                (throw key #t)))))
    (parameterize ((%allow-request? skip-if-limit-reached))
      (catch key
        (lambda ()
          (lookup-origin "http://example.org/guix.git")
          #f)
        (const #t)))))

(test-end "swh")

;; Local Variables:
;; eval: (put 'with-json-result 'scheme-indent-function 1)
;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; End: