code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-store)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix monads)
  #:use-module (gcrypt hash)
  #: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 (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")))

(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 ((nix-connection-error? c)
               (and (eq? port (nix-connection-error-file c))
                    (nix-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 13))

(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-assert "valid-path? error"
  (with-store s
    (guard (c ((nix-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 ((nix-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 "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 vs. delete-paths"
  ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
  ;; is no longer valid.
  (with-store store
    (let* ((text    (random-text))
           (path    (add-text-to-store store "delete-me" text))
           (deleted (delete-paths store (list path)))
           (path2   (add-text-to-store store "delete-me" text)))
      (and (string=? path path2)
           (equal? deleted (list path))
           (valid-path? store path)
           (file-exists? path)))))

(test-assert "add-to-store vs. delete-paths"
  ;; Same as above.
  (with-store store
    (let* ((file    (search-path %load-path "guix.scm"))
           (path    (add-to-store store "delete-me" #t "sha256" file))
           (deleted (delete-paths store (list path)))
           (path2   (add-to-store store "delete-me" #t "sha256" file)))
      (and (string=? path path2)
           (equal? deleted (list path))
           (valid-path? store path)
           (file-exists? path)))))

(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-assert "references/substitutes missing reference info"
  (with-store s
    (set-build-options s #:use-substitutes? #f)
    (guard (c ((nix-protocol-error? c) #t))
      (let* ((b  (add-to-store s "bash" #t "sha256"
                               (search-bootstrap-binary "bash"
                                                        (%current-system))))
             (d  (derivation s "the-thing" b '("--help")
                             #:inputs `((,b)))))
        (references/substitutes s (list (derivation->output-path d) b))
        #f))))

(test-assert "references/substitutes with substitute info"
  (with-store s
    (set-build-options s #:use-substitutes? #t)
    (let* ((t1 (add-text-to-store s "random1" (random-text)))
           (t2 (add-text-to-store s "random2" (random-text)
                                  (list t1)))
           (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
           (b  (add-to-store s "bash" #t "sha256"
                             (search-bootstrap-binary "bash"
                                                      (%current-system))))
           (d  (derivation s "the-thing" b `("-e" ,t3)
                           #:inputs `((,b) (,t3) (,t2))
                           #:env-vars `(("t2" . ,t2))))
           (o  (derivation->output-path d)))
      (with-derivation-narinfo d
        (sha256 => (sha256 (string->utf8 t2)))
        (references => (list t2))

        (equal? (references/substitutes s (list o t3 t2 t1))
                `((,t2)                           ;refs of O
                  ()                              ;refs of T3
                  (,t1)                           ;refs of T2
                  ()))))))                        ;refs of T1

(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-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 ((nix-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 ((nix-protocol-error? c) #t))
              (build-derivations %store (list d))))))))
   (cond-expand
     (guile-2.2 "garbage: �lambda: λ")
     (else      "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))
             (equal? c (call-with-input-file o get-string-all)))))))

(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)
             (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 ((nix-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? (nix-protocol-error-status c)))))
               (build-derivations s (list d))
               #f))))))

(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 ((nix-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 ((nix-protocol-error? c)
               (and (not (zero? (nix-protocol-error-status c)))
                    (string-contains (nix-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) (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 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 ((nix-protocol-error? c)
                    (pk 'c c)
                    (and (not (zero? (nix-protocol-error-status c)))
                         (string-contains (nix-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 ((nix-protocol-error? c)
                           (pk 'determinism-exception c)
                           (and (not (zero? (nix-protocol-error-status c)))
                                (string-contains (nix-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 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 ((nix-protocol-error? c)
                    (pk 'multiple-build c)
                    (and (not (zero? (nix-protocol-error-status c)))
                         (string-contains (nix-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)
                 (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-end "store")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-substitute)
  #:use-module (guix scripts substitute)
  #:use-module (guix base64)
  #:use-module (gcrypt hash)
  #:use-module (guix serialization)
  #:use-module (gcrypt pk-crypto)
  #:use-module (guix pki)
  #:use-module (guix config)
  #:use-module (guix base32)
  #:use-module ((guix store) #:select (%store-prefix))
  #:use-module ((guix ui) #:select (guix-warning-port))
  #:use-module ((guix build utils)
                #:select (mkdir-p delete-file-recursively))
  #:use-module (guix tests http)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (web uri)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module ((srfi srfi-64) #:hide (test-error)))

(define-syntax-rule (test-quit name error-rx exp)
  "Emit a test that passes when EXP throws to 'quit' with value 1, and when
it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX."
  (test-equal name
    '(1 #t)
    (let ((error-output (open-output-string)))
      (parameterize ((guix-warning-port error-output))
        (catch 'quit
          (lambda ()
            exp
            #f)
          (lambda (key value)
            (list value
                  (let ((message (get-output-string error-output)))
                    (->bool (string-match error-rx message))))))))))

(define %public-key
  ;; This key is known to be in the ACL by default.
  (call-with-input-file (string-append %config-directory "/signing-key.pub")
    (compose string->canonical-sexp get-string-all)))

(define %private-key
  (call-with-input-file (string-append %config-directory "/signing-key.sec")
    (compose string->canonical-sexp get-string-all)))

(define* (signature-body bv #:key (public-key %public-key))
  "Return the signature of BV as the base64-encoded body of a narinfo's
'Signature' field."
  (base64-encode
   (string->utf8
    (canonical-sexp->string
     (signature-sexp (bytevector->hash-data (sha256 bv)
                                            #:key-type 'rsa)
                     %private-key
                     public-key)))))

(define %wrong-public-key
  (string->canonical-sexp "(public-key
 (rsa
  (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#)
  (e #010001#)
  )
 )"))

(define* (signature-field bv-or-str
                          #:key (version "1") (public-key %public-key))
  "Return the 'Signature' field value of bytevector/string BV-OR-STR, using
PUBLIC-KEY as the signature's principal, and using VERSION as the signature
version identifier.."
  (string-append version ";example.gnu.org;"
                 (signature-body (if (string? bv-or-str)
                                     (string->utf8 bv-or-str)
                                     bv-or-str)
                                 #:public-key public-key)))

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

        (set! (@@ (guix scripts substitute)
                  %allow-unauthenticated-substitutes?)
              #f))
      thunk
      (lambda ()
        (when (file-exists? cache-directory)
          (delete-file-recursively cache-directory))))))

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

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

;; Transmit these options to 'guix substitute'.
(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))

(test-equal "query narinfo without signature"
  ""                                              ; not substitutable

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

(test-equal "query narinfo with invalid hash"
  ;; The hash in the signature differs from the hash of %NARINFO.
  ""

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

(test-equal "query narinfo signed with authorized key"
  (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")

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

(test-equal "query narinfo signed with unauthorized key"
  ""                                              ; not substitutable

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

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

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

(test-quit "substitute, unauthorized key"
    "no valid substitute"
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field
                                %narinfo
                                #:public-key %wrong-public-key)
                               "\n")
    (guix-substitute "--substitute"
                     (string-append (%store-prefix)
                                    "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                     "foo")))

(test-equal "substitute, authorized key"
  "Substitutable data."
  (with-narinfo (string-append %narinfo "Signature: "
                               (signature-field %narinfo))
    (dynamic-wind
      (const #t)
      (lambda ()
        (guix-substitute "--substitute"
                         (string-append (%store-prefix)
                                        "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                         "substitute-retrieved")
        (call-with-input-file "substitute-retrieved" get-string-all))
      (lambda ()
        (false-if-exception (delete-file "substitute-retrieved"))))))

(test-equal "substitute, unauthorized narinfo comes first"
  "Substitutable data."
  (with-narinfo*
      (string-append %narinfo "Signature: "
                     (signature-field
                      %narinfo
                      #:public-key %wrong-public-key))
      %alternate-substitute-directory

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

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

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--substitute"
                             (string-append (%store-prefix)
                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                             "substitute-retrieved"))
          (call-with-input-file "substitute-retrieved" get-string-all))
        (lambda ()
          (false-if-exception (delete-file "substitute-retrieved")))))))

(test-equal "substitute, unsigned narinfo comes first"
  "Substitutable data."
  (with-narinfo* %narinfo                         ;not signed!
      %alternate-substitute-directory

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

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

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--substitute"
                             (string-append (%store-prefix)
                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                             "substitute-retrieved"))
          (call-with-input-file "substitute-retrieved" get-string-all))
        (lambda ()
          (false-if-exception (delete-file "substitute-retrieved")))))))

(test-equal "substitute, first narinfo is unsigned and has wrong hash"
  "Substitutable data."
  (with-narinfo* (regexp-substitute #f
                                    (string-match "NarHash: [[:graph:]]+"
                                                  %narinfo)
                                    'pre
                                    "NarHash: sha256:"
                                    (bytevector->nix-base32-string
                                     (make-bytevector 32))
                                    'post)
      %alternate-substitute-directory

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

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

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--substitute"
                             (string-append (%store-prefix)
                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                             "substitute-retrieved"))
          (call-with-input-file "substitute-retrieved" get-string-all))
        (lambda ()
          (false-if-exception (delete-file "substitute-retrieved")))))))

(test-equal "substitute, first narinfo is unsigned and has wrong refs"
  "Substitutable data."
  (with-narinfo* (regexp-substitute #f
                                    (string-match "References: ([^\n]+)\n"
                                                  %narinfo)
                                    'pre "References: " 1
                                    " wrong set of references\n"
                                    'post)
      %alternate-substitute-directory

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

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

          (parameterize ((substitute-urls
                          (map (cut string-append "file://" <>)
                               (list %alternate-substitute-directory
                                     %main-substitute-directory))))
            (guix-substitute "--substitute"
                             (string-append (%store-prefix)
                                            "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                             "substitute-retrieved"))
          (call-with-input-file "substitute-retrieved" get-string-all))
        (lambda ()
          (false-if-exception (delete-file "substitute-retrieved")))))))

(test-quit "substitute, two invalid narinfos"
    "no valid substitute"
  (with-narinfo* %narinfo                         ;not signed
      %alternate-substitute-directory

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

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

(test-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:

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@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-syscalls)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (gnu build linux-container)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (system foreign)
  #:use-module ((ice-9 ftw) #:select (scandir))
  #:use-module (ice-9 match))

;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.

(define temp-file
  (string-append "t-utils-" (number->string (getpid))))

(test-begin "syscalls")

(test-equal "mount, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (mount "/dev/null" "/does-not-exist" "ext2")
      #f)
    (compose system-error-errno list)))

(test-assert "umount, ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (umount "/does-not-exist")
      #f)
    (lambda args
      ;; Both return values have been encountered in the wild.
      (memv (system-error-errno args) (list EPERM ENOENT)))))

(test-assert "mount-points"
  ;; Reportedly "/" is not always listed as a mount point, so check a few
  ;; others (see <http://bugs.gnu.org/20261>.)
  (any (cute member <> (mount-points))
       '("/" "/proc" "/sys" "/dev")))

(false-if-exception (delete-file temp-file))
(test-equal "utime with AT_SYMLINK_NOFOLLOW"
  '(0 0)
  (begin
    ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not
    ;; define as of Guile 2.2.4.
    (symlink "/nowhere" temp-file)
    (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW)
    (let ((st (lstat temp-file)))
      (delete-file temp-file)
      ;; Note: 'utimensat' does not change 'ctime'.
      (list (stat:mtime st) (stat:atime st)))))

(test-assert "swapon, ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (swapon "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM ENOENT)))))

(test-assert "swapoff, ENOENT/EINVAL/EPERM"
  (catch 'system-error
    (lambda ()
      (swapoff "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))

(test-assert "mkdtemp!"
  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
         (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
    (and (file-exists? dir)
         (begin
           (rmdir dir)
           #t))))

(test-equal "statfs, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (statfs "/does-not-exist"))
    (compose system-error-errno list)))

(test-assert "statfs"
  (let ((fs (statfs "/")))
    (and (file-system? fs)
         (> (file-system-block-size fs) 0)
         (>= (file-system-blocks-available fs) 0)
         (>= (file-system-blocks-free fs)
             (file-system-blocks-available fs)))))

(define (user-namespace pid)
  (string-append "/proc/" (number->string pid) "/ns/user"))

(define perform-container-tests?
  (and (user-namespace-supported?)
       (unprivileged-user-namespace-supported?)))

(unless perform-container-tests?
  (test-skip 1))
(test-assert "clone"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 42))
    (pid
     ;; Check if user namespaces are different.
     (and (not (equal? (readlink (user-namespace pid))
                       (readlink (user-namespace (getpid)))))
          (match (waitpid pid)
            ((_ . status)
             (= 42 (status:exit-val status))))))))

(unless perform-container-tests?
  (test-skip 1))
(test-assert "setns"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 0))
    (clone-pid
     (match (pipe)
       ((in . out)
        (match (primitive-fork)
          (0
           (close in)
           ;; Join the user namespace.
           (call-with-input-file (user-namespace clone-pid)
             (lambda (port)
               (setns (port->fdes port) 0)))
           (write 'done out)
           (close out)
           (primitive-exit 0))
          (fork-pid
           (close out)
           ;; Wait for the child process to join the namespace.
           (read in)
           (let ((result (and (equal? (readlink (user-namespace clone-pid))
                                      (readlink (user-namespace fork-pid))))))
             ;; Clean up.
             (waitpid clone-pid)
             (waitpid fork-pid)
             result))))))))

;; XXX: Skip this test when running Linux > 4.7.5 to work around
;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>.
(when (or (not perform-container-tests?)
          (version>? (utsname:release (uname)) "4.7.5")

          ;; Skip on Ubuntu's 4.4 kernels, which contain a backport of the
          ;; faulty code: <https://bugs.gnu.org/25476>.
          (member (utsname:release (uname))
                  '("4.4.0-21-generic" "4.4.0-59-generic"
                    "4.4.0-116-generic")))
  (test-skip 1))
(test-equal "pivot-root"
  #t
  (match (pipe)
    ((in . out)
     (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close in)
            (call-with-temporary-directory
             (lambda (root)
               (let ((put-old (string-append root "/real-root")))
                 (mount "none" root "tmpfs")
                 (mkdir put-old)
                 (call-with-output-file (string-append root "/test")
                   (lambda (port)
                     (display "testing\n" port)))
                 (pivot-root root put-old)
                 ;; The test file should now be located inside the root directory.
                 (write (file-exists? "/test") out)
                 (close out)))))
          (lambda ()
            (primitive-exit 0))))
       (pid
        (close out)
        (let ((result (read in)))
          (close in)
          (and (zero? (match (waitpid pid)
                        ((_ . status)
                         (status:exit-val status))))
               (eq? #t result))))))))

(test-equal "scandir*, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (scandir* "/does/not/exist"))
    (lambda args
      (system-error-errno args))))

(test-equal "scandir*, ASCII file names"
  (scandir (dirname (search-path %load-path "guix/base32.scm"))
           (const #t) string<?)
  (match (scandir* (dirname (search-path %load-path "guix/base32.scm")))
    (((names . properties) ...)
     names)))

(test-equal "scandir*, UTF-8 file names"
  '("." ".." "α" "λ")
  (call-with-temporary-directory
   (lambda (directory)
     ;; Wrap 'creat' to make sure that we really pass a UTF-8-encoded file
     ;; name to the system call.
     (let ((creat (pointer->procedure int
                                      (dynamic-func "creat" (dynamic-link))
                                      (list '* int))))
       (creat (string->pointer (string-append directory "/α")
                               "UTF-8")
              #o644)
       (creat (string->pointer (string-append directory "/λ")
                               "UTF-8")
              #o644)
       (let ((locale (setlocale LC_ALL)))
         (dynamic-wind
           (lambda ()
             ;; Make sure that even in a C locale we get the right result.
             (setlocale LC_ALL "C"))
           (lambda ()
             (match (scandir* directory)
               (((names . properties) ...)
                names)))
           (lambda ()
             (setlocale LC_ALL locale))))))))

(test-assert "scandir*, properties"
  (let ((directory (dirname (search-path %load-path "guix/base32.scm"))))
    (every (lambda (entry name)
             (match entry
               ((name2 . properties)
                (and (string=? name2 name)
                     (let* ((full  (string-append directory "/" name))
                            (stat  (lstat full))
                            (inode (assoc-ref properties 'inode))
                            (type  (assoc-ref properties 'type)))
                       (and (= inode (stat:ino stat))
                            (or (eq? type 'unknown)
                                (eq? type (stat:type stat)))))))))
           (scandir* directory)
           (scandir directory (const #t) string<?))))

(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
  42                                              ; the child's exit status
  (let ((file (open-file temp-file "w0b")))
    ;; Acquire an exclusive lock.
    (fcntl-flock file 'write-lock)
    (match (primitive-fork)
      (0
       (dynamic-wind
         (const #t)
         (lambda ()
           ;; Reopen FILE read-only so we can have a read lock.
           (let ((file (open-file temp-file "r0b")))
             ;; Wait until we can acquire the lock.
             (fcntl-flock file 'read-lock)
             (primitive-exit (read file)))
           (primitive-exit 1))
         (lambda ()
           (primitive-exit 2))))
      (pid
       ;; Write garbage and wait.
       (display "hello, world!"  file)
       (force-output file)
       (sleep 1)

       ;; Write the real answer.
       (seek file 0 SEEK_SET)
       (truncate-file file 0)
       (write 42 file)
       (force-output file)

       ;; Unlock, which should let the child continue.
       (fcntl-flock file 'unlock)

       (match (waitpid pid)
         ((_  . status)
          (let ((result (status:exit-val status)))
            (close-port file)
            result)))))))

(test-equal "fcntl-flock non-blocking"
  EAGAIN                                          ; the child's exit status
  (match (pipe)
    ((input . output)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close-port output)

            ;; Wait for the green light.
            (read-char input)

            ;; Open FILE read-only so we can have a read lock.
            (let ((file (open-file temp-file "w0")))
              (catch 'flock-error
                (lambda ()
                  ;; This attempt should throw EAGAIN.
                  (fcntl-flock file 'write-lock #:wait? #f))
                (lambda (key errno)
                  (primitive-exit (pk 'errno errno)))))
            (primitive-exit -1))
          (lambda ()
            (primitive-exit -2))))
       (pid
        (close-port input)
        (let ((file (open-file temp-file "w0")))
          ;; Acquire an exclusive lock.
          (fcntl-flock file 'write-lock)

          ;; Tell the child to continue.
          (write 'green-light output)
          (force-output output)

          (match (waitpid pid)
            ((_  . status)
             (let ((result (status:exit-val status)))
               (fcntl-flock file 'unlock)
               (close-port file)
               result)))))))))

(test-equal "set-thread-name"
  "Syscall Test"
  (let ((name (thread-name)))
    (set-thread-name "Syscall Test")
    (let ((new-name (thread-name)))
      (set-thread-name name)
      new-name)))

(test-assert "all-network-interface-names"
  (match (all-network-interface-names)
    (((? string? names) ..1)
     (member "lo" names))))

(test-assert "network-interface-names"
  (match (network-interface-names)
    (((? string? names) ..1)
     (lset<= string=? names (all-network-interface-names)))))

(test-assert "network-interface-flags"
  (let* ((sock  (socket AF_INET SOCK_STREAM 0))
         (flags (network-interface-flags sock "lo")))
    (close-port sock)
    (and (not (zero? (logand flags IFF_LOOPBACK)))
         (not (zero? (logand flags IFF_UP))))))

(test-equal "loopback-network-interface?"
  ENODEV
  (and (loopback-network-interface? "lo")
       (catch 'system-error
         (lambda ()
           (loopback-network-interface? "nonexistent")
           #f)
         (lambda args
           (system-error-errno args)))))

(test-equal "loopback-network-interface-running?"
  ENODEV
  (and (network-interface-running? "lo")
       (catch 'system-error
         (lambda ()
           (network-interface-running? "nonexistent")
           #f)
         (lambda args
           (system-error-errno args)))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-flags"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-flags sock "lo" IFF_UP))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interface-address lo"
  (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
  (let* ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (network-interface-address sock "lo")))
    (close-port sock)
    addr))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-address"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-address sock "nonexistent"
                                       (make-socket-address
                                        AF_INET
                                        (inet-pton AF_INET "127.12.14.15")
                                        0)))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interface-netmask lo"
  (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0)
  (let* ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (network-interface-netmask sock "lo")))
    (close-port sock)
    addr))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-netmask"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-netmask sock "nonexistent"
                                       (make-socket-address
                                        AF_INET
                                        (inet-pton AF_INET "255.0.0.0")
                                        0)))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interfaces returns one or more interfaces"
  '(#t #t #t)
  (match (network-interfaces)
    ((interfaces ..1)
     (list (every interface? interfaces)
           (every string? (map interface-name interfaces))
           (every (lambda (sockaddr)
                    ;; Sometimes interfaces have no associated address.
                    (or (vector? sockaddr)
                        (not sockaddr)))
                  (map interface-address interfaces))))))

(test-equal "network-interfaces returns \"lo\""
  (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0))
  (match (filter (lambda (interface)
                   (string=? "lo" (interface-name interface)))
                 (network-interfaces))
    ((loopbacks ..1)
     (list (every (lambda (lo)
                    (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
                  loopbacks)
           (match (find (lambda (lo)
                          (= AF_INET (sockaddr:fam (interface-address lo))))
                        loopbacks)
             (#f #f)
             (lo (interface-address lo)))))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "add-network-route/gateway"
  (let ((sock    (socket AF_INET SOCK_STREAM 0))
        (gateway (make-socket-address AF_INET
                                      (inet-pton AF_INET "192.168.0.1")
                                      0)))
    (catch 'system-error
      (lambda ()
        (add-network-route/gateway sock gateway))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "delete-network-route"
  (let ((sock        (socket AF_INET SOCK_STREAM 0))
        (destination (make-socket-address AF_INET INADDR_ANY 0)))
    (catch 'system-error
      (lambda ()
        (delete-network-route sock destination))
      (lambda args
        (close-port sock)
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "tcgetattr ENOTTY"
  ENOTTY
  (catch 'system-error
    (lambda ()
      (call-with-input-file "/dev/null"
        (lambda (port)
          (tcgetattr (fileno port)))))
    (compose system-error-errno list)))

(test-skip (if (and (file-exists? "/proc/self/fd/0")
                    (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0")))
               0
               2))

(test-assert "tcgetattr"
  (let ((termios (tcgetattr 0)))
    (and (termios? termios)
         (> (termios-input-speed termios) 0)
         (> (termios-output-speed termios) 0))))

(test-assert "tcsetattr"
  (let ((first (tcgetattr 0)))
    (tcsetattr 0 (tcsetattr-action TCSANOW) first)
    (equal? first (tcgetattr 0))))

(test-assert "terminal-window-size ENOTTY"
  (call-with-input-file "/dev/null"
    (lambda (port)
      (catch 'system-error
        (lambda ()
          (terminal-window-size port))
        (lambda args
          ;; Accept EINVAL, which some old Linux versions might return.
          (memv (system-error-errno args)
                (list ENOTTY EINVAL)))))))

(test-assert "terminal-columns"
  (> (terminal-columns) 0))

(test-assert "terminal-columns non-file port"
  (> (terminal-columns (open-input-string "Join us now, share the software!"))
     0))

(test-assert "utmpx-entries"
  (match (utmpx-entries)
    (((? utmpx? entries) ...)
     (every (lambda (entry)
              (match (utmpx-user entry)
                ((? string?)
                 ;; Ensure we have a valid PID for those entries where it
                 ;; makes sense.
                 (or (not (memv (utmpx-login-type entry)
                                (list (login-type INIT_PROCESS)
                                      (login-type LOGIN_PROCESS)
                                      (login-type USER_PROCESS))))
                     (> (utmpx-pid entry) 0)))
                (#f                               ;might be DEAD_PROCESS
                 #t)))
            entries))))

(test-assert "read-utmpx, EOF"
  (eof-object? (read-utmpx (%make-void-port "r"))))

(unless (access? "/var/run/utmpx" O_RDONLY)
  (test-skip 1))
(test-assert "read-utmpx"
  (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx)))
    (or (utmpx? result) (eof-object? result))))

(test-end)

(false-if-exception (delete-file temp-file))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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-system)
  #:use-module (gnu)
  #:use-module ((gnu services) #:select (service-value))
  #:use-module (guix store)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

;; Test the (gnu system) module.

(define %root-fs
  (file-system
    (device (file-system-label "my-root"))
    (mount-point "/")
    (type "ext4")))

(define %os
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
    (file-systems (cons %root-fs %base-file-systems))

    (users %base-user-accounts)))

(define %luks-device
  (mapped-device
   (source "/dev/foo") (target "my-luks-device")
   (type luks-device-mapping)))

(define %os-with-mapped-device
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
    (mapped-devices (list %luks-device))
    (file-systems (cons (file-system
                          (inherit %root-fs)
                          (dependencies (list %luks-device)))
                        %base-file-systems))
    (users %base-user-accounts)))

(test-begin "system")

(test-assert "operating-system-store-file-system"
  ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
  ;; shouldn't be a problem.
  (eq? %root-fs
       (operating-system-store-file-system %os)))

(test-assert "operating-system-store-file-system, prefix"
  (let* ((gnu (file-system
                (device "foobar")
                (mount-point (dirname (%store-prefix)))
                (type "ext5")))
         (os  (operating-system
                (inherit %os)
                (file-systems (cons* gnu %root-fs
                                     %base-file-systems)))))
    (eq? gnu (operating-system-store-file-system os))))

(test-assert "operating-system-store-file-system, store"
  (let* ((gnu (file-system
                (device "foobar")
                (mount-point (%store-prefix))
                (type "ext5")))
         (os  (operating-system
                (inherit %os)
                (file-systems (cons* gnu %root-fs
                                     %base-file-systems)))))
    (eq? gnu (operating-system-store-file-system os))))

(test-equal "operating-system-user-mapped-devices"
  '()
  (operating-system-user-mapped-devices %os-with-mapped-device))

(test-equal "operating-system-boot-mapped-devices"
  (list %luks-device)
  (operating-system-boot-mapped-devices %os-with-mapped-device))

(test-equal "operating-system-boot-mapped-devices, implicit dependency"
  (list %luks-device)

  ;; Here we expect the implicit dependency between "/" and
  ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
  ;; 'dependencies' field in the root file system.
  (operating-system-boot-mapped-devices
   (operating-system
     (inherit %os-with-mapped-device)
     (file-systems (cons (file-system
                           (device "/dev/mapper/my-luks-device")
                           (mount-point "/")
                           (type "ext4"))
                         %base-file-systems)))))

(test-equal "non-boot-file-system-service"
  '()

  ;; Make sure that mapped devices with at least one needed-for-boot user are
  ;; handled exclusively from the initrd.  See <https://bugs.gnu.org/31889>.
  (append-map file-system-dependencies
              (service-value
               ((@@ (gnu system) non-boot-file-system-service)
                (operating-system
                  (inherit %os-with-mapped-device)
                  (file-systems
                   (list (file-system
                           (mount-point "/foo/bar")
                           (device "qux:baz")
                           (type "none")
                           (dependencies (list %luks-device)))
                         (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
                           (type "ext4")
                           (dependencies (list %luks-device))))))))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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-texlive)
  #:use-module (gnu packages tex)
  #:use-module (guix import texlive)
  #:use-module (guix tests)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match))

(test-begin "texlive")

(define xml
  "\
<entry id=\"foo\">
   <name>foo</name>

Foomatic frobnication in LuaLaTeX

   <authorref id=\"rekado\"/>
   <license type=\"lppl1.3\"/>
   <version number=\"2.6a\"/>
   <description>

          Foo is a package for LuaLaTeX. It provides an interface to frobnicate gimbals
          in a foomatic way with the LuaTeX engine.

          The package requires the bar and golly
          bundles for extremely special specialties.

   </description>
   <ctan path=\"/macros/latex/contrib/foo\" file=\"true\"/>
   <texlive location=\"foo\"/>
   <keyval key=\"topic\" value=\"tests\"/>
  null
</entry>")

(define sxml
  '(*TOP* (entry (@ (id "foo"))
                 (name "foo")
                 (caption "Foomatic frobnication in LuaLaTeX")
                 (authorref (@ (id "rekado")))
                 (license (@ (type "lppl1.3")))
                 (version (@ (number "2.6a")))
                 (description
                  (p "\n          Foo is a package for LuaLaTeX. It provides an interface to frobnicate gimbals\n          in a foomatic way with the LuaTeX engine.\n     ")
                  (p "\n          The package requires the bar and golly\n          bundles for extremely special specialties.\n     "))
                 (ctan (@ (path "/macros/latex/contrib/foo") (file "true")))
                 (texlive (@ (location "foo")))
                 (keyval (@ (value "tests") (key "topic")))
                 "\n  null\n")))

(test-equal "fetch-sxml: returns SXML for valid XML"
  sxml
  (mock ((guix http-client) http-fetch
         (lambda (url)
           xml))
        ((@@ (guix import texlive) fetch-sxml) "foo")))

;; TODO:
(test-assert "sxml->package"
  ;; Replace network resources with sample data.
  (mock ((guix build svn) svn-fetch
         (lambda* (url revision directory
                       #:key (svn-command "svn")
                       (user-name #f)
                       (password #f))
           (mkdir-p directory)
           (with-output-to-file (string-append directory "/foo")
             (lambda ()
               (display "source")))))
        (let ((result ((@@ (guix import texlive) sxml->package) sxml)))
          (match result
            (('package
               ('name "texlive-latex-foo")
               ('version "2.6a")
               ('source ('origin
                          ('method 'svn-fetch)
                          ('uri ('texlive-ref "latex" "foo"))
                          ('sha256
                           ('base32
                            (? string? hash)))))
               ('build-system 'texlive-build-system)
               ('arguments ('quote (#:tex-directory "latex/foo")))
               ('home-page "http://www.ctan.org/pkg/foo")
               ('synopsis "Foomatic frobnication in LuaLaTeX")
               ('description
                "Foo is a package for LuaLaTeX.  It provides an interface to \
frobnicate gimbals in a foomatic way with the LuaTeX engine.  The package \
requires the bar and golly bundles for extremely special specialties.")
               ('license 'lppl1.3+))
             #t)
            (_
             (begin
               (format #t "~s\n" result)
               (pk 'fail result #f)))))))

(test-end "texlive")