code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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/>.

(unsetenv "http_proxy")

(define-module (test-derivations)
  #:use-module (guix derivations)
  #:use-module (guix grafts)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module ((gcrypt hash) #:prefix gcrypt:)
  #:use-module (guix base32)
  #:use-module (guix tests)
  #:use-module (guix tests http)
  #:use-module ((guix packages) #:select (package-derivation base32))
  #:use-module ((guix build utils) #:select (executable-file?))
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages guile) #:select (guile-1.8))
  #: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)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match))

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

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define (bootstrap-binary name)
  (let ((bin (search-bootstrap-binary name (%current-system))))
    (and %store
         (add-to-store %store name #t "sha256" bin))))

(define %bash
  (bootstrap-binary "bash"))
(define %mkdir
  (bootstrap-binary "mkdir"))

(define* (directory-contents dir #:optional (slurp get-bytevector-all))
  "Return an alist representing the contents of DIR."
  (define prefix-len (string-length dir))
  (sort (file-system-fold (const #t)                   ; enter?
                          (lambda (path stat result)   ; leaf
                            (alist-cons (string-drop path prefix-len)
                                        (call-with-input-file path slurp)
                                        result))
                          (lambda (path stat result) result)      ; down
                          (lambda (path stat result) result)      ; up
                          (lambda (path stat result) result)      ; skip
                          (lambda (path stat errno result) result) ; error
                          '()
                          dir)
        (lambda (e1 e2)
          (string<? (car e1) (car e2)))))

(test-begin "derivations")

(test-assert "parse & export"
  (let* ((f  (search-path %load-path "tests/test.drv"))
         (b1 (call-with-input-file f get-bytevector-all))
         (d1 (read-derivation (open-bytevector-input-port b1)
                              identity))
         (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
         (d2 (read-derivation (open-bytevector-input-port b2)
                              identity)))
    (and (equal? b1 b2)
         (equal? d1 d2))))

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

(test-assert "add-to-store, flat"
  ;; Use 'readlink*' in case spec.scm is a symlink, as is the case when Guile
  ;; was installed with Stow.
  (let* ((file (readlink*
                (search-path %load-path "language/tree-il/spec.scm")))
         (drv  (add-to-store %store "flat-test" #f "sha256" file)))
    (and (eq? 'regular (stat:type (stat drv)))
         (valid-path? %store drv)
         (equal? (call-with-input-file file get-bytevector-all)
                 (call-with-input-file drv get-bytevector-all)))))

(test-assert "add-to-store, recursive"
  (let* ((dir (dirname
               (readlink* (search-path %load-path
                                       "language/tree-il/spec.scm"))))
         (drv (add-to-store %store "dir-tree-test" #t "sha256" dir)))
    (and (eq? 'directory (stat:type (stat drv)))
         (valid-path? %store drv)
         (equal? (directory-contents dir)
                 (directory-contents drv)))))

(test-assert "derivation with no inputs"
  (let* ((builder  (add-text-to-store %store "my-builder.sh"
                                      "echo hello, world\n"
                                      '()))
         (drv      (derivation %store "foo"
                               %bash `("-e" ,builder)
                               #:env-vars '(("HOME" . "/homeless")))))
    (and (store-path? (derivation-file-name drv))
         (valid-path? %store (derivation-file-name drv)))))

(test-assert "build derivation with 1 source"
  (let* ((builder (add-text-to-store %store "my-builder.sh"
                                     "echo hello, world > \"$out\"\n"
                                     '()))
         (drv     (derivation %store "foo"
                              %bash `(,builder)
                              #:env-vars '(("HOME" . "/homeless")
                                           ("zzz"  . "Z!")
                                           ("AAA"  . "A!"))
                              #:sources `(,%bash ,builder)))
         (succeeded?
          (build-derivations %store (list drv))))
    (and succeeded?
         (let ((path (derivation->output-path drv)))
           (and (valid-path? %store path)
                (string=? (call-with-input-file path read-line)
                          "hello, world"))))))

(test-assert "derivation fails but keep going"
  ;; In keep-going mode, 'build-derivations' should fail because of D1, but it
  ;; must return only after D2 has succeeded.
  (with-store store
    (let* ((d1 (derivation %store "fails"
                           %bash `("-c" "false")
                           #:sources (list %bash)))
           (d2 (build-expression->derivation %store "sleep-then-succeed"
                                             `(begin
                                                ,(random-text)
                                                ;; XXX: Hopefully that's long
                                                ;; enough that D1 has already
                                                ;; failed.
                                                (sleep 2)
                                                (mkdir %output)))))
      (set-build-options %store
                         #:use-substitutes? #f
                         #:keep-going? #t)
      (guard (c ((store-protocol-error? c)
                 (and (= 100 (store-protocol-error-status c))
                      (string-contains (store-protocol-error-message c)
                                       (derivation-file-name d1))
                      (not (valid-path? %store (derivation->output-path d1)))
                      (valid-path? %store (derivation->output-path d2)))))
        (build-derivations %store (list d1 d2))
        #f))))

(test-assert "identical files are deduplicated"
  (let* ((build1  (add-text-to-store %store "one.sh"
                                     "echo hello, world > \"$out\"\n"
                                     '()))
         (build2  (add-text-to-store %store "two.sh"
                                     "# Hey!\necho hello, world > \"$out\"\n"
                                     '()))
         (drv1    (derivation %store "foo"
                              %bash `(,build1)
                              #:sources `(,%bash ,build1)))
         (drv2    (derivation %store "bar"
                              %bash `(,build2)
                              #:sources `(,%bash ,build2))))
    (and (build-derivations %store (list drv1 drv2))
         (let ((file1 (derivation->output-path drv1))
               (file2 (derivation->output-path drv2)))
           (and (valid-path? %store file1) (valid-path? %store file2)
                (string=? (call-with-input-file file1 get-string-all)
                          "hello, world\n")
                (= (stat:ino (lstat file1))
                   (stat:ino (lstat file2))))))))

(test-equal "built-in-builders"
  '("download")
  (built-in-builders %store))

(test-assert "unknown built-in builder"
  (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '())))
    (guard (c ((store-protocol-error? c)
               (string-contains (store-protocol-error-message c) "failed")))
      (build-derivations %store (list drv))
      #f)))

(test-assert "'download' built-in builder"
  (let ((text (random-text)))
    (with-http-server `((200 ,text))
      (let* ((drv (derivation %store "world"
                              "builtin:download" '()
                              #:env-vars `(("url"
                                            . ,(object->string (%local-url))))
                              #:hash-algo 'sha256
                              #:hash (gcrypt:sha256 (string->utf8 text)))))
        (and (build-derivations %store (list drv))
             (string=? (call-with-input-file (derivation->output-path drv)
                         get-string-all)
                       text))))))

(test-assert "'download' built-in builder, invalid hash"
  (with-http-server `((200 "hello, world!"))
    (let* ((drv (derivation %store "world"
                            "builtin:download" '()
                            #:env-vars `(("url"
                                          . ,(object->string (%local-url))))
                            #:hash-algo 'sha256
                            #:hash (gcrypt:sha256 (random-bytevector 100))))) ;wrong
      (guard (c ((store-protocol-error? c)
                 (string-contains (store-protocol-error-message c) "failed")))
        (build-derivations %store (list drv))
        #f))))

(test-assert "'download' built-in builder, not found"
  (with-http-server '((404 "not found"))
    (let* ((drv (derivation %store "will-never-be-found"
                            "builtin:download" '()
                            #:env-vars `(("url"
                                          . ,(object->string (%local-url))))
                            #:hash-algo 'sha256
                            #:hash (gcrypt:sha256 (random-bytevector 100)))))
      (guard (c ((store-protocol-error? c)
                 (string-contains (store-protocol-error-message (pk c)) "failed")))
        (build-derivations %store (list drv))
        #f))))

(test-assert "'download' built-in builder, not fixed-output"
  (let* ((source (add-text-to-store %store "hello" "hi!"))
         (url    (string-append "file://" source))
         (drv    (derivation %store "world"
                             "builtin:download" '()
                             #:env-vars `(("url" . ,(object->string url))))))
    (guard (c ((store-protocol-error? c)
               (string-contains (store-protocol-error-message c) "failed")))
      (build-derivations %store (list drv))
      #f)))

(test-assert "'download' built-in builder, check mode"
  ;; Make sure rebuilding the 'builtin:download' derivation in check mode
  ;; works.  See <http://bugs.gnu.org/25089>.
  (let* ((text (random-text)))
    (with-http-server `((200 ,text))
      (let ((drv (derivation %store "world"
                             "builtin:download" '()
                             #:env-vars `(("url"
                                           . ,(object->string (%local-url))))
                             #:hash-algo 'sha256
                             #:hash (gcrypt:sha256 (string->utf8 text)))))
        (and drv (build-derivations %store (list drv))
             (with-http-server `((200 ,text))
               (build-derivations %store (list drv)
                                  (build-mode check)))
             (string=? (call-with-input-file (derivation->output-path drv)
                         get-string-all)
                       text))))))

(test-equal "derivation-name"
  "foo-0.0"
  (let ((drv (derivation %store "foo-0.0" %bash '())))
    (derivation-name drv)))

(test-equal "derivation-output-names"
  '(("out") ("bar" "chbouib"))
  (let ((drv1 (derivation %store "foo-0.0" %bash '()))
        (drv2 (derivation %store "foo-0.0" %bash '()
                          #:outputs '("bar" "chbouib"))))
    (list (derivation-output-names drv1)
          (derivation-output-names drv2))))

(test-assert "offloadable-derivation?"
  (and (offloadable-derivation? (derivation %store "foo" %bash '()))
       (offloadable-derivation?               ;see <http://bugs.gnu.org/18747>
        (derivation %store "foo" %bash '()
                    #:substitutable? #f))
       (not (offloadable-derivation?
             (derivation %store "foo" %bash '()
                         #:local-build? #t)))))

(test-assert "substitutable-derivation?"
  (and (substitutable-derivation? (derivation %store "foo" %bash '()))
       (substitutable-derivation?             ;see <http://bugs.gnu.org/18747>
        (derivation %store "foo" %bash '()
                    #:local-build? #t))
       (not (substitutable-derivation?
             (derivation %store "foo" %bash '()
                         #:substitutable? #f)))))

(test-assert "fixed-output-derivation?"
  (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                        "echo -n hello > $out" '()))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (drv        (derivation %store "fixed"
                                 %bash `(,builder)
                                 #:sources (list builder)
                                 #:hash hash #:hash-algo 'sha256)))
    (fixed-output-derivation? drv)))

(test-equal "fixed-output derivation"
  '(sha1 sha256 sha512)
  (map (lambda (hash-algorithm)
         (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
                                            "echo -n hello > $out" '()))
                (sha256  (gcrypt:sha256 (string->utf8 "hello")))
                (hash    (gcrypt:bytevector-hash
                          (string->utf8 "hello")
                          (gcrypt:lookup-hash-algorithm hash-algorithm)))
                (drv     (derivation %store
                                     (string-append
                                      "fixed-" (symbol->string hash-algorithm))
                                     %bash `(,builder)
                                     #:sources `(,builder) ;optional
                                     #:hash hash
                                     #:hash-algo hash-algorithm)))
           (build-derivations %store (list drv))
           (let ((p (derivation->output-path drv)))
             (and (bytevector=? (string->utf8 "hello")
                                (call-with-input-file p get-bytevector-all))
                  (bytevector? (query-path-hash %store p))
                  hash-algorithm))))
       '(sha1 sha256 sha512)))

(test-assert "fixed-output derivation: output paths are equal"
  (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
                                        "echo -n hello > $out" '()))
         (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                        "echo hey; echo -n hello > $out" '()))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (drv1       (derivation %store "fixed"
                                 %bash `(,builder1)
                                 #:hash hash #:hash-algo 'sha256))
         (drv2       (derivation %store "fixed"
                                 %bash `(,builder2)
                                 #:hash hash #:hash-algo 'sha256))
         (succeeded? (build-derivations %store (list drv1 drv2))))
    (and succeeded?
         (equal? (derivation->output-path drv1)
                 (derivation->output-path drv2)))))

(test-assert "fixed-output derivation, recursive"
  (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                        "echo -n hello > $out" '()))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (drv        (derivation %store "fixed-rec"
                                 %bash `(,builder)
                                 #:sources (list builder)
                                 #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
                                 #:hash-algo 'sha256
                                 #:recursive? #t))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((p (derivation->output-path drv)))
           (and (equal? (string->utf8 "hello")
                        (call-with-input-file p get-bytevector-all))
                (bytevector? (query-path-hash %store p)))))))

(test-assert "derivation with a fixed-output input"
  ;; A derivation D using a fixed-output derivation F doesn't has the same
  ;; output path when passed F or F', as long as F and F' have the same output
  ;; path.
  (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
                                        "echo -n hello > $out" '()))
         (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                        "echo hey; echo -n hello > $out" '()))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (fixed1     (derivation %store "fixed"
                                 %bash `(,builder1)
                                 #:hash hash #:hash-algo 'sha256))
         (fixed2     (derivation %store "fixed"
                                 %bash `(,builder2)
                                 #:hash hash #:hash-algo 'sha256))
         (fixed-out  (derivation->output-path fixed1))
         (builder3   (add-text-to-store
                      %store "final-builder.sh"
                      ;; Use Bash hackery to avoid Coreutils.
                      "echo $in ; (read -u 3 c; echo $c) 3< $in > $out" '()))
         (final1     (derivation %store "final"
                                 %bash `(,builder3)
                                 #:env-vars `(("in" . ,fixed-out))
                                 #:sources (list %bash builder3)
                                 #:inputs (list (derivation-input fixed1))))
         (final2     (derivation %store "final"
                                 %bash `(,builder3)
                                 #:env-vars `(("in" . ,fixed-out))
                                 #:sources (list %bash builder3)
                                 #:inputs (list (derivation-input fixed2))))
         (succeeded? (build-derivations %store
                                        (list final1 final2))))
    (and succeeded?
         (equal? (derivation->output-path final1)
                 (derivation->output-path final2)))))

(test-assert "derivation with duplicate fixed-output inputs"
  ;; Here we create a derivation that has two inputs, both of which are
  ;; fixed-output leading to the same result.  This test ensures the hash of
  ;; that derivation is correctly computed, namely that duplicate inputs are
  ;; coalesced.  See <https://bugs.gnu.org/36777>.
  (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
                                        "echo -n hello > $out" '()))
         (builder2   (add-text-to-store %store "fixed-builder2.sh"
                                        "echo hey; echo -n hello > $out" '()))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (fixed1     (derivation %store "fixed"
                                 %bash `(,builder1)
                                 #:hash hash #:hash-algo 'sha256))
         (fixed2     (derivation %store "fixed"
                                 %bash `(,builder2)
                                 #:hash hash #:hash-algo 'sha256))
         (builder3   (add-text-to-store %store "builder.sh"
                                        "echo fake builder"))
         (final      (derivation %store "final"
                                 %bash `(,builder3)
                                 #:sources (list %bash builder3)
                                 #:inputs (list (derivation-input fixed1)
                                                (derivation-input fixed2)))))
    (and (derivation? final)
         (match (derivation-inputs final)
           (((= derivation-input-derivation one)
             (= derivation-input-derivation two))
            (and (not (string=? (derivation-file-name one)
                                (derivation-file-name two)))
                 (string=? (derivation->output-path one)
                           (derivation->output-path two))))))))

(test-assert "multiple-output derivation"
  (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                        "echo one > $out ; echo two > $second"
                                        '()))
         (drv        (derivation %store "fixed"
                                 %bash `(,builder)
                                 #:env-vars '(("HOME" . "/homeless")
                                              ("zzz"  . "Z!")
                                              ("AAA"  . "A!"))
                                 #:sources `(,%bash ,builder)
                                 #:outputs '("out" "second")))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((one (derivation->output-path drv "out"))
               (two (derivation->output-path drv "second")))
           (and (lset= equal?
                       (derivation->output-paths drv)
                       `(("out" . ,one) ("second" . ,two)))
                (eq? 'one (call-with-input-file one read))
                (eq? 'two (call-with-input-file two read)))))))

(test-assert "multiple-output derivation, non-alphabetic order"
  ;; Here, the outputs are not listed in alphabetic order.  Yet, the store
  ;; path computation must reorder them first.
  (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                        "echo one > $out ; echo two > $AAA"
                                        '()))
         (drv        (derivation %store "fixed"
                                 %bash `(,builder)
                                 #:sources `(,%bash ,builder)
                                 #:outputs '("out" "AAA")))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((one (derivation->output-path drv "out"))
               (two (derivation->output-path drv "AAA")))
           (and (eq? 'one (call-with-input-file one read))
                (eq? 'two (call-with-input-file two read)))))))

(test-assert "read-derivation vs. derivation"
  ;; Make sure 'derivation' and 'read-derivation' return objects that are
  ;; identical.
  (let* ((sources (unfold (cut >= <> 10)
                          (lambda (n)
                            (add-text-to-store %store
                                               (format #f "input~a" n)
                                               (random-text)))
                          1+
                          0))
         (inputs  (map (lambda (file)
                         (derivation %store "derivation-input"
                                     %bash '()
                                     #:sources `(,%bash ,file)))
                       sources))
         (builder (add-text-to-store %store "builder.sh"
                                     "echo one > $one ; echo two > $two"
                                     '()))
         (drv     (derivation %store "derivation"
                              %bash `(,builder)
                              #:sources `(,%bash ,builder ,@sources)
                              #:inputs (map derivation-input inputs)
                              #:outputs '("two" "one")))
         (drv*    (call-with-input-file (derivation-file-name drv)
                    read-derivation)))
    (equal? drv* drv)))

(test-assert "multiple-output derivation, derivation-path->output-path"
  (let* ((builder    (add-text-to-store %store "builder.sh"
                                        "echo one > $out ; echo two > $second"
                                        '()))
         (drv        (derivation %store "multiple"
                                 %bash `(,builder)
                                 #:outputs '("out" "second")))
         (drv-file   (derivation-file-name drv))
         (one        (derivation->output-path drv "out"))
         (two        (derivation->output-path drv "second"))
         (first      (derivation-path->output-path drv-file "out"))
         (second     (derivation-path->output-path drv-file "second")))
    (and (not (string=? one two))
         (string-suffix? "-second" two)
         (string=? first one)
         (string=? second two))))

(test-assert "user of multiple-output derivation"
  ;; Check whether specifying several inputs coming from the same
  ;; multiple-output derivation works.
  (let* ((builder1   (add-text-to-store %store "my-mo-builder.sh"
                                        "echo one > $out ; echo two > $two"
                                        '()))
         (mdrv       (derivation %store "multiple-output"
                                 %bash `(,builder1)
                                 #:sources (list %bash builder1)
                                 #:outputs '("out" "two")))
         (builder2   (add-text-to-store %store "my-mo-user-builder.sh"
                                        "read x < $one;
                                         read y < $two;
                                         echo \"($x $y)\" > $out"
                                        '()))
         (udrv       (derivation %store "multiple-output-user"
                                 %bash `(,builder2)
                                 #:env-vars `(("one"
                                               . ,(derivation->output-path
                                                   mdrv "out"))
                                              ("two"
                                               . ,(derivation->output-path
                                                   mdrv "two")))
                                 #:sources (list %bash builder2)
                                 ;; two occurrences of MDRV:
                                 #:inputs
                                 (list (derivation-input mdrv)
                                       (derivation-input mdrv '("two"))))))
    (and (build-derivations %store (list (pk 'udrv udrv)))
         (let ((p (derivation->output-path udrv)))
           (and (valid-path? %store p)
                (equal? '(one two) (call-with-input-file p read)))))))

(test-assert "derivation with #:references-graphs"
  (let* ((input1  (add-text-to-store %store "foo" "hello"
                                     (list %bash)))
         (input2  (add-text-to-store %store "bar"
                                     (number->string (random 7777))
                                     (list input1)))
         (builder (add-text-to-store %store "build-graph"
                                     (format #f "
~a $out
 (while read l ; do echo $l ; done) < bash > $out/bash
 (while read l ; do echo $l ; done) < input1 > $out/input1
 (while read l ; do echo $l ; done) < input2 > $out/input2"
                                             %mkdir)
                                     (list %mkdir)))
         (drv     (derivation %store "closure-graphs"
                              %bash `(,builder)
                              #:references-graphs
                              `(("bash" . ,%bash)
                                ("input1" . ,input1)
                                ("input2" . ,input2))
                              #:sources (list %bash builder)))
         (out     (derivation->output-path drv)))
    (define (deps path . deps)
      (let ((count (length deps)))
        (string-append path "\n\n" (number->string count) "\n"
                       (string-join (sort deps string<?) "\n")
                       (if (zero? count) "" "\n"))))

    (and (build-derivations %store (list drv))
         (equal? (directory-contents out get-string-all)
                 `(("/bash"   . ,(string-append %bash "\n\n0\n"))
                   ("/input1" . ,(if (string>? input1 %bash)
                                     (string-append (deps %bash)
                                                    (deps input1 %bash))
                                     (string-append (deps input1 %bash)
                                                    (deps %bash))))
                   ("/input2" . ,(string-concatenate
                                  (map cdr
                                       (sort
                                        (map (lambda (p d)
                                               (cons p (apply deps p d)))
                                             (list %bash input1 input2)
                                             (list '() (list %bash) (list input1)))
                                        (lambda (x y)
                                          (match x
                                            ((p1 . _)
                                             (match y
                                               ((p2 . _)
                                                (string<? p1 p2)))))))))))))))

(test-assert "derivation #:allowed-references, ok"
  (let ((drv (derivation %store "allowed" %bash
                         '("-c" "echo hello > $out")
                         #:sources (list %bash)
                         #:allowed-references '())))
    (build-derivations %store (list drv))))

(test-assert "derivation #:allowed-references, not allowed"
  (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
         (drv (derivation %store "disallowed" %bash
                          `("-c" ,(string-append "echo " txt "> $out"))
                          #:sources (list %bash txt)
                          #:allowed-references '())))
    (guard (c ((store-protocol-error? c)
               ;; There's no specific error message to check for.
               #t))
      (build-derivations %store (list drv))
      #f)))

(test-assert "derivation #:allowed-references, self allowed"
  (let ((drv (derivation %store "allowed" %bash
                         '("-c" "echo $out > $out")
                         #:sources (list %bash)
                         #:allowed-references '("out"))))
    (build-derivations %store (list drv))))

(test-assert "derivation #:allowed-references, self not allowed"
  (let ((drv (derivation %store "disallowed" %bash
                         `("-c" ,"echo $out > $out")
                         #:sources (list %bash)
                         #:allowed-references '())))
    (guard (c ((store-protocol-error? c)
               ;; There's no specific error message to check for.
               #t))
      (build-derivations %store (list drv))
      #f)))

(test-assert "derivation #:disallowed-references, ok"
  (let ((drv (derivation %store "disallowed" %bash
                         '("-c" "echo hello > $out")
                         #:sources (list %bash)
                         #:disallowed-references '("out"))))
    (build-derivations %store (list drv))))

(test-assert "derivation #:disallowed-references, not ok"
  (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
         (drv (derivation %store "disdisallowed" %bash
                          `("-c" ,(string-append "echo " txt "> $out"))
                          #:sources (list %bash txt)
                          #:disallowed-references (list txt))))
    (guard (c ((store-protocol-error? c)
               ;; There's no specific error message to check for.
               #t))
      (build-derivations %store (list drv))
      #f)))

;; Here we should get the value of $GUIX_STATE_DIRECTORY that the daemon sees,
;; which is a unique value for each test process; this value is the same as
;; the one we see in the process executing this file since it is set by
;; 'test-env'.
(test-equal "derivation #:leaked-env-vars"
  (getenv "GUIX_STATE_DIRECTORY")
  (let* ((value (getenv "GUIX_STATE_DIRECTORY"))
         (drv   (derivation %store "leaked-env-vars" %bash
                            '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out")
                            #:hash (gcrypt:sha256 (string->utf8 value))
                            #:hash-algo 'sha256
                            #:sources (list %bash)
                            #:leaked-env-vars '("GUIX_STATE_DIRECTORY"))))
    (and (build-derivations %store (list drv))
         (call-with-input-file (derivation->output-path drv)
           get-string-all))))

(define %coreutils
  (false-if-exception
   (and (network-reachable?)
        (package-derivation %store %bootstrap-coreutils&co))))

(test-skip (if %coreutils 0 1))

(test-assert "build derivation with coreutils"
  (let* ((builder
          (add-text-to-store %store "build-with-coreutils.sh"
                             "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
                             '()))
         (drv
          (derivation %store "foo"
                      %bash `(,builder)
                      #:env-vars `(("PATH" .
                                    ,(string-append
                                      (derivation->output-path %coreutils)
                                      "/bin")))
                      #:sources (list builder)
                      #:inputs (list (derivation-input %coreutils))))
         (succeeded?
          (build-derivations %store (list drv))))
    (and succeeded?
         (let ((p (derivation->output-path drv)))
           (and (valid-path? %store p)
                (file-exists? (string-append p "/good")))))))

(test-skip (if (%guile-for-build) 0 8))

(test-equal "build-expression->derivation and invalid module name"
  '(file-search-error "guix/module/that/does/not/exist.scm")
  (guard (c ((file-search-error? c)
             (list 'file-search-error
                   (file-search-error-file-name c))))
    (build-expression->derivation %store "foo" #t
                                  #:modules '((guix module that
                                                    does not exist)))))

(test-equal "build-expression->derivation and builder encoding"
  '("UTF-8" #t)
  (let* ((exp '(λ (α) (+ α 1)))
         (drv (build-expression->derivation %store "foo" exp)))
    (match (derivation-builder-arguments drv)
      ((... builder)
       (with-fluids ((%default-port-encoding "UTF-8"))
         (call-with-input-file builder
           (lambda (port)
             (list (port-encoding port)
                   (->bool
                    (string-contains (get-string-all port)
                                     "(λ (α) (+ α 1))"))))))))))

(test-assert "build-expression->derivation and derivation-prerequisites"
  (let ((drv (build-expression->derivation %store "fail" #f)))
    (any (match-lambda
          (($ <derivation-input> (= derivation-file-name path))
           (string=? path (derivation-file-name (%guile-for-build)))))
         (derivation-prerequisites drv))))

(test-assert "derivation-prerequisites and valid-derivation-input?"
  (let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
         (b (build-expression->derivation %store "b" `(list ,(random-text))))
         (c (build-expression->derivation %store "c" `(mkdir %output)
                                          #:inputs `(("a" ,a) ("b" ,b)))))
    ;; Make sure both A and %BOOTSTRAP-GUILE are built (the latter could have
    ;; be removed by tests/guix-gc.sh.)
    (build-derivations %store
                       (list a (package-derivation %store %bootstrap-guile)))

    (match (derivation-prerequisites c
                                     (cut valid-derivation-input? %store
                                          <>))
      ((($ <derivation-input> (= derivation-file-name file) ("out")))
       (string=? file (derivation-file-name b)))
      (x
       (pk 'fail x #f)))))

(test-assert "build-expression->derivation without inputs"
  (let* ((builder    '(begin
                        (mkdir %output)
                        (call-with-output-file (string-append %output "/test")
                          (lambda (p)
                            (display '(hello guix) p)))))
         (drv        (build-expression->derivation %store "goo" builder))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((p (derivation->output-path drv)))
           (equal? '(hello guix)
                   (call-with-input-file (string-append p "/test") read))))))

(test-assert "build-expression->derivation and max-silent-time"
  (let* ((store      (let ((s (open-connection)))
                       (set-build-options s #:max-silent-time 1)
                       s))
         (builder    '(begin (sleep 100) (mkdir %output) #t))
         (drv        (build-expression->derivation store "silent" builder))
         (out-path   (derivation->output-path drv)))
    (guard (c ((store-protocol-error? c)
               (and (string-contains (store-protocol-error-message c)
                                     "failed")
                    (not (valid-path? store out-path)))))
      (build-derivations store (list drv))
      #f)))

(test-assert "build-expression->derivation and timeout"
  (let* ((store      (let ((s (open-connection)))
                       (set-build-options s #:timeout 1)
                       s))
         (builder    '(begin (sleep 100) (mkdir %output) #t))
         (drv        (build-expression->derivation store "slow" builder))
         (out-path   (derivation->output-path drv)))
    (guard (c ((store-protocol-error? c)
               (and (string-contains (store-protocol-error-message c)
                                     "failed")
                    (not (valid-path? store out-path)))))
      (build-derivations store (list drv))
      #f)))

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

             ;; Ask for nothing but the "out" output of DRV.
             (build-derivations store `((,drv . "out")))

             ;; Synonymous:
             (build-derivations store (list (derivation-input drv '("out"))))

             (valid-path? store out)
             (equal? (pk 'x content)
                     (pk 'y (call-with-input-file out get-string-all))))))))

(test-assert "build-expression->derivation and derivation-build-plan"
  (let ((drv (build-expression->derivation %store "fail" #f)))
    ;; The only direct dependency is (%guile-for-build) and it's already
    ;; built.
    (null? (derivation-build-plan %store (derivation-inputs drv)))))

(test-assert "derivation-build-plan when outputs already present"
  (let* ((builder    `(begin ,(random-text) (mkdir %output) #t))
         (input-drv  (build-expression->derivation %store "input" builder))
         (input-path (derivation->output-path input-drv))
         (drv        (build-expression->derivation %store "something" builder
                                                   #:inputs
                                                   `(("i" ,input-drv))))
         (output     (derivation->output-path drv)))
    ;; Assume these things are not already built.
    (when (or (valid-path? %store input-path)
              (valid-path? %store output))
      (error "things already built" input-drv))

    (and (lset= equal?
                (map derivation-file-name
                     (derivation-build-plan %store
                                            (list (derivation-input drv))))
                (list (derivation-file-name input-drv)
                      (derivation-file-name drv)))

         ;; Build DRV and delete its input.
         (build-derivations %store (list drv))
         (delete-paths %store (list input-path))
         (not (valid-path? %store input-path))

         ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
         ;; prerequisite to build because DRV itself is already built.
         (null? (derivation-build-plan %store
                                       (list (derivation-input drv)))))))

(test-assert "derivation-build-plan and substitutes"
  (let* ((store  (open-connection))
         (drv    (build-expression->derivation store "prereq-subst"
                                               (random 1000)))
         (output (derivation->output-path drv)))

    ;; Make sure substitutes are usable.
    (set-build-options store #:use-substitutes? #t
                       #:substitute-urls (%test-substitute-urls))

    (with-derivation-narinfo drv
      (let-values (((build download)
                    (derivation-build-plan store
                                           (list (derivation-input drv))))
                   ((build* download*)
                    (derivation-build-plan store
                                           (list (derivation-input drv))
                                           #:substitutable-info
                                           (const #f))))
        (and (null? build)
             (equal? (map substitutable-path download) (list output))
             (null? download*)
             (equal? (list drv) build*))))))

(test-assert "derivation-build-plan and substitutes, non-substitutable build"
  (let* ((store  (open-connection))
         (drv    (build-expression->derivation store "prereq-no-subst"
                                               (random 1000)
                                               #:substitutable? #f))
         (output (derivation->output-path drv)))

    ;; Make sure substitutes are usable.
    (set-build-options store #:use-substitutes? #t
                       #:substitute-urls (%test-substitute-urls))

    (with-derivation-narinfo drv
      (let-values (((build download)
                    (derivation-build-plan store
                                           (list (derivation-input drv)))))
        ;; Despite being available as a substitute, DRV will be built locally
        ;; due to #:substitutable? #f.
        (and (null? download)
             (match build
               (((= derivation-file-name build))
                (string=? build (derivation-file-name drv)))))))))

(test-assert "derivation-build-plan and substitutes, non-substitutable dep"
  (with-store store
    (let* ((drv1 (build-expression->derivation store "prereq-no-subst"
                                               (random 1000)
                                               #:substitutable? #f))
           (drv2 (build-expression->derivation store "substitutable"
                                               (random 1000)
                                               #:inputs `(("dep" ,drv1)))))

      ;; Make sure substitutes are usable.
      (set-build-options store #:use-substitutes? #t
                         #:substitute-urls (%test-substitute-urls))

      (with-derivation-narinfo drv2
        (sha256 => (make-bytevector 32 0))
        (references => (list (derivation->output-path drv1)))

        (let-values (((build download)
                      (derivation-build-plan store
                                             (list (derivation-input drv2)))))
          ;; Although DRV2 is available as a substitute, we must build its
          ;; dependency, DRV1, due to #:substitutable? #f.
          (and (match download
                 (((= substitutable-path item))
                  (string=? item (derivation->output-path drv2))))
               (match build
                 (((= derivation-file-name build))
                  (string=? build (derivation-file-name drv1))))))))))

(test-assert "derivation-build-plan and substitutes, local build"
  (with-store store
    (let* ((drv    (build-expression->derivation store "prereq-subst-local"
                                                 (random 1000)
                                                 #:local-build? #t))
           (output (derivation->output-path drv)))

      ;; Make sure substitutes are usable.
      (set-build-options store #:use-substitutes? #t
                         #:substitute-urls (%test-substitute-urls))

      (with-derivation-narinfo drv
        (let-values (((build download)
                      (derivation-build-plan store
                                             (list (derivation-input drv)))))
          ;; #:local-build? is *not* synonymous with #:substitutable?, so we
          ;; must be able to substitute DRV's output.
          ;; See <http://bugs.gnu.org/18747>.
          (and (null? build)
               (match download
                 (((= substitutable-path item))
                  (string=? item (derivation->output-path drv))))))))))

(test-assert "derivation-build-plan in 'check' mode"
  (with-store store
    (let* ((dep (build-expression->derivation store "dep"
                                              `(begin ,(random-text)
                                                      (mkdir %output))))
           (drv (build-expression->derivation store "to-check"
                                              '(mkdir %output)
                                              #:inputs `(("dep" ,dep)))))
      (build-derivations store (list drv))
      (delete-paths store (list (derivation->output-path dep)))

      ;; In 'check' mode, DEP must be rebuilt.
      (and (null? (derivation-build-plan store
                                         (list (derivation-input drv))))
           (lset= equal?
                  (derivation-build-plan store
                                         (list (derivation-input drv))
                                         #:mode (build-mode check))
                  (list drv dep))))))

(test-assert "derivation-input-fold"
  (let* ((builder (add-text-to-store %store "my-builder.sh"
                                     "echo hello, world > \"$out\"\n"
                                     '()))
         (drv1    (derivation %store "foo"
                              %bash `(,builder)
                              #:sources `(,%bash ,builder)))
         (drv2    (derivation %store "bar"
                              %bash `(,builder)
                              #:inputs `((,drv1))
                              #:sources `(,%bash ,builder))))
    (equal? (derivation-input-fold (lambda (input result)
                                     (cons (derivation-input-derivation input)
                                           result))
                                   '()
                                   (list (derivation-input drv2)))
            (list drv1 drv2))))

(test-assert "substitution-oracle and #:substitute? #f"
  (with-store store
    (let* ((dep   (build-expression->derivation store "dep"
                                                `(begin ,(random-text)
                                                        (mkdir %output))))
           (drv   (build-expression->derivation store "not-subst"
                                                `(begin ,(random-text)
                                                        (mkdir %output))
                                                #:substitutable? #f
                                                #:inputs `(("dep" ,dep))))
           (query #f))
      (define (record-substitutable-path-query store paths)
        (when query
          (error "already called!" query))
        (set! query paths)
        '())

      (mock ((guix store) substitutable-path-info
             record-substitutable-path-query)

            (let ((pred (substitution-oracle store (list drv))))
              (pred (derivation->output-path drv))))

      ;; Make sure the oracle didn't try to get substitute info for DRV since
      ;; DRV is mark as non-substitutable.  Assume that GUILE-FOR-BUILD is
      ;; already in store and thus not part of QUERY.
      (equal? (pk 'query query)
              (list (derivation->output-path dep))))))

(test-assert "build-expression->derivation with expression returning #f"
  (let* ((builder  '(begin
                      (mkdir %output)
                      #f))                        ; fail!
         (drv      (build-expression->derivation %store "fail" builder))
         (out-path (derivation->output-path drv)))
    (guard (c ((store-protocol-error? c)
               ;; Note that the output path may exist at this point, but it
               ;; is invalid.
               (and (string-match "build .* failed"
                                  (store-protocol-error-message c))
                    (not (valid-path? %store out-path)))))
      (build-derivations %store (list drv))
      #f)))

(test-assert "build-expression->derivation with two outputs"
  (let* ((builder    '(begin
                        (call-with-output-file (assoc-ref %outputs "out")
                          (lambda (p)
                            (display '(hello) p)))
                        (call-with-output-file (assoc-ref %outputs "second")
                          (lambda (p)
                            (display '(world) p)))))
         (drv        (build-expression->derivation %store "double" builder
                                                   #:outputs '("out"
                                                               "second")))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((one (derivation->output-path drv))
               (two (derivation->output-path drv "second")))
           (and (equal? '(hello) (call-with-input-file one read))
                (equal? '(world) (call-with-input-file two read)))))))

(test-skip (if %coreutils 0 1))
(test-assert "build-expression->derivation with one input"
  (let* ((builder    '(call-with-output-file %output
                        (lambda (p)
                          (let ((cu (assoc-ref %build-inputs "cu")))
                            (close 1)
                            (dup2 (port->fdes p) 1)
                            (execl (string-append cu "/bin/uname")
                                   "uname" "-a")))))
         (drv        (build-expression->derivation %store "uname" builder
                                                   #:inputs
                                                   `(("cu" ,%coreutils))))
         (succeeded? (build-derivations %store (list drv))))
    (and succeeded?
         (let ((p (derivation->output-path drv)))
           (string-contains (call-with-input-file p read-line) "GNU")))))

(test-assert "build-expression->derivation with modules"
  (let* ((builder  `(begin
                      (use-modules (guix build utils))
                      (let ((out (assoc-ref %outputs "out")))
                        (mkdir-p (string-append out "/guile/guix/nix"))
                        #t)))
         (drv      (build-expression->derivation %store "test-with-modules"
                                                 builder
                                                 #:modules
                                                 '((guix build utils)))))
    (and (build-derivations %store (list drv))
         (let* ((p (derivation->output-path drv))
                (s (stat (string-append p "/guile/guix/nix"))))
           (eq? (stat:type s) 'directory)))))

(test-assert "build-expression->derivation: same fixed-output path"
  (let* ((builder1   '(call-with-output-file %output
                        (lambda (p)
                          (write "hello" p))))
         (builder2   '(call-with-output-file (pk 'difference-here! %output)
                        (lambda (p)
                          (write "hello" p))))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (input1     (build-expression->derivation %store "fixed" builder1
                                                   #:hash hash
                                                   #:hash-algo 'sha256))
         (input2     (build-expression->derivation %store "fixed" builder2
                                                   #:hash hash
                                                   #:hash-algo 'sha256))
         (succeeded? (build-derivations %store (list input1 input2))))
    (and succeeded?
         (not (string=? (derivation-file-name input1)
                        (derivation-file-name input2)))
         (string=? (derivation->output-path input1)
                   (derivation->output-path input2)))))

(test-assert "build-expression->derivation with a fixed-output input"
  (let* ((builder1   '(call-with-output-file %output
                        (lambda (p)
                          (write "hello" p))))
         (builder2   '(call-with-output-file (pk 'difference-here! %output)
                        (lambda (p)
                          (write "hello" p))))
         (hash       (gcrypt:sha256 (string->utf8 "hello")))
         (input1     (build-expression->derivation %store "fixed" builder1
                                                   #:hash hash
                                                   #:hash-algo 'sha256))
         (input2     (build-expression->derivation %store "fixed" builder2
                                                   #:hash hash
                                                   #:hash-algo 'sha256))
         (builder3  '(let ((input (assoc-ref %build-inputs "input")))
                       (call-with-output-file %output
                         (lambda (out)
                           (format #f "My input is ~a.~%" input)))))
         (final1    (build-expression->derivation %store "final" builder3
                                                  #:inputs
                                                  `(("input" ,input1))))
         (final2    (build-expression->derivation %store "final" builder3
                                                  #:inputs
                                                  `(("input" ,input2)))))
    (and (string=? (derivation->output-path final1)
                   (derivation->output-path final2))
         (string=? (derivation->output-path final1)
                   (derivation-path->output-path
                    (derivation-file-name final1)))
         (build-derivations %store (list final1 final2)))))

(test-assert "build-expression->derivation produces recursive fixed-output"
  (let* ((builder '(begin
                     (use-modules (srfi srfi-26))
                     (mkdir %output)
                     (chdir %output)
                     (call-with-output-file "exe"
                       (cut display "executable" <>))
                     (chmod "exe" #o777)
                     (symlink "exe" "symlink")
                     (mkdir "subdir")))
         (drv     (build-expression->derivation %store "fixed-rec" builder
                                                #:hash-algo 'sha256
                                                #:hash (base32
                                                        "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p")
                                                #:recursive? #t)))
    (and (build-derivations %store (list drv))
         (let* ((dir    (derivation->output-path drv))
                (exe    (string-append dir "/exe"))
                (link   (string-append dir "/symlink"))
                (subdir (string-append dir "/subdir")))
           (and (executable-file? exe)
                (string=? "executable"
                          (call-with-input-file exe get-string-all))
                (string=? "exe" (readlink link))
                (file-is-directory? subdir))))))

(test-assert "build-expression->derivation uses recursive fixed-output"
  (let* ((builder '(call-with-output-file %output
                     (lambda (port)
                       (display "hello" port))))
         (fixed   (build-expression->derivation %store "small-fixed-rec"
                                                builder
                                                #:hash-algo 'sha256
                                                #:hash (base32
                                                        "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
                                                #:recursive? #t))
         (in      (derivation->output-path fixed))
         (builder `(begin
                     (mkdir %output)
                     (chdir %output)
                     (symlink ,in "symlink")))
         (drv     (build-expression->derivation %store "fixed-rec-user"
                                                builder
                                                #:inputs `(("fixed" ,fixed)))))
    (and (build-derivations %store (list drv))
         (let ((out (derivation->output-path drv)))
           (string=? (readlink (string-append out "/symlink")) in)))))

(test-assert "build-expression->derivation with #:references-graphs"
  (let* ((input   (add-text-to-store %store "foo" "hello"
                                     (list %bash %mkdir)))
         (builder '(copy-file "input" %output))
         (drv     (build-expression->derivation %store "references-graphs"
                                                builder
                                                #:references-graphs
                                                `(("input" . ,input))))
         (out     (derivation->output-path drv)))
    (define (deps path . deps)
      (let ((count (length deps)))
        (string-append path "\n\n" (number->string count) "\n"
                       (string-join (sort deps string<?) "\n")
                       (if (zero? count) "" "\n"))))

    (and (build-derivations %store (list drv))
         (equal? (call-with-input-file out get-string-all)
                 (string-concatenate
                  (map cdr
                       (sort (map (lambda (p d)
                                    (cons p (apply deps p d)))
                                  (list input %bash %mkdir)
                                  (list (list %bash %mkdir)
                                        '() '()))
                             (lambda (x y)
                               (match x
                                 ((p1 . _)
                                  (match y
                                    ((p2 . _)
                                     (string<? p1 p2)))))))))))))

(test-equal "derivation-properties"
  (list '() '((type . test)))
  (let ((drv1 (build-expression->derivation %store "bar"
                                            '(mkdir %output)))
        (drv2 (build-expression->derivation %store "foo"
                                           '(mkdir %output)
                                           #:properties '((type . test)))))
    (list (derivation-properties drv1)
          (derivation-properties drv2))))

(test-equal "map-derivation"
  "hello"
  (let* ((joke (package-derivation %store guile-1.8))
         (good (package-derivation %store %bootstrap-guile))
         (drv1 (build-expression->derivation %store "original-drv1"
                                             #f   ; systematically fail
                                             #:guile-for-build joke))
         (drv2 (build-expression->derivation %store "original-drv2"
                                             '(call-with-output-file %output
                                                (lambda (p)
                                                  (display "hello" p)))))
         (drv3 (build-expression->derivation %store "drv-to-remap"
                                             '(let ((in (assoc-ref
                                                         %build-inputs "in")))
                                                (copy-file in %output))
                                             #:inputs `(("in" ,drv1))
                                             #:guile-for-build joke))
         (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
                                             (,joke . ,good))))
         (out  (derivation->output-path drv4)))
    (and (build-derivations %store (list (pk 'remapped drv4)))
         (call-with-input-file out get-string-all))))

(test-equal "map-derivation, sources"
  "hello"
  (let* ((script1   (add-text-to-store %store "fail.sh" "exit 1"))
         (script2   (add-text-to-store %store "hi.sh" "echo -n hello > $out"))
         (bash-full (package-derivation %store (@ (gnu packages bash) bash)))
         (drv1      (derivation %store "drv-to-remap"

                                ;; XXX: This wouldn't work in practice, but if
                                ;; we append "/bin/bash" then we can't replace
                                ;; it with the bootstrap bash, which is a
                                ;; single file.
                                (derivation->output-path bash-full)

                                `("-e" ,script1)
                                #:sources (list script1)
                                #:inputs
                                (list (derivation-input bash-full '("out")))))
         (drv2      (map-derivation %store drv1
                                    `((,bash-full . ,%bash)
                                      (,script1 . ,script2))))
         (out       (derivation->output-path drv2)))
    (and (build-derivations %store (list (pk 'remapped* drv2)))
         (call-with-input-file out get-string-all))))

(test-end)

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 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-discovery)
  #:use-module (guix discovery)
  #:use-module (guix build-system)
  #:use-module (guix utils)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define %top-srcdir
  (dirname (search-path %load-path "guix.scm")))

(test-begin "discovery")

(test-assert "scheme-modules"
  (match (map module-name (scheme-modules %top-srcdir "guix/import"))
    ((('guix 'import _ ...) ..1)
     #t)))

(test-assert "scheme-modules recurses in symlinks to directories"
  (call-with-temporary-directory
   (lambda (directory)
     (mkdir (string-append directory "/guix"))
     (symlink (string-append %top-srcdir "/guix/import")
              (string-append directory "/guix/import"))

     ;; DIRECTORY/guix/import is a symlink but we want to make sure
     ;; 'scheme-modules' recurses into it.
     (match (map module-name (scheme-modules directory))
       ((('guix 'import _ ...) ..1)
        #t)))))

(test-equal "scheme-modules, non-existent directory"
  '()
  (scheme-modules "/does/not/exist"))

(test-assert "all-modules"
  (match (map module-name
              (all-modules `((,%top-srcdir . "guix/build-system"))))
    ((('guix 'build-system names) ..1)
     names)))

(test-assert "fold-module-public-variables"
  (let ((modules (all-modules `((,%top-srcdir . "guix/build-system")))))
    (match (fold-module-public-variables (lambda (obj result)
                                           (if (build-system? obj)
                                               (cons obj result)
                                               result))
                                         '()
                                         modules)
      (((? build-system? bs) ..1)
       bs))))

(test-end "discovery")

repo_name: maximed/guix

license: mit


code:
-----BEGIN PGP PUBLIC KEY BLOCK-----

mDMEXqNaoBYJKwYBBAHaRw8BAQdArviKtelb4g0I3zx9xyDS40Oz8i1/LRXqppG6
b23Hdim0KEVkIFR3by1GaWZ0eSA8bHVkbyt0ZXN0LWVjY0BjaGJvdWliLm9yZz6I
lgQTFggAPhYhBETTHiGvcTj5tjIoCncfScv6rgctBQJeo1qgAhsDBQkDwmcABQsJ
CAcCBhUKCQgLAgQWAgMBAh4BAheAAAoJEHcfScv6rgctq4MA/1R9G0roEwrHwmTd
DHxt211eLqupwXE0Z7xY2FH6DHk9AP4owEefBU7jQprSAzBS+c6gdS3SCCKKqAh6
ToZ4LmbKAw==
=FXMK
-----END PGP PUBLIC KEY BLOCK-----


code:
-----BEGIN PGP PRIVATE KEY BLOCK-----

lFgEXqNaoBYJKwYBBAHaRw8BAQdArviKtelb4g0I3zx9xyDS40Oz8i1/LRXqppG6
b23HdikAAQDGgjcUcvqR+nGYcf5UHzy9xlO/dBZX4f9QV1ILDIGt0hAYtChFZCBU
d28tRmlmdHkgPGx1ZG8rdGVzdC1lY2NAY2hib3VpYi5vcmc+iJYEExYIAD4WIQRE
0x4hr3E4+bYyKAp3H0nL+q4HLQUCXqNaoAIbAwUJA8JnAAULCQgHAgYVCgkICwIE
FgIDAQIeAQIXgAAKCRB3H0nL+q4HLauDAP9UfRtK6BMKx8Jk3Qx8bdtdXi6rqcFx
NGe8WNhR+gx5PQD+KMBHnwVO40Ka0gMwUvnOoHUt0ggiiqgIek6GeC5mygM=
=VjjI
-----END PGP PRIVATE KEY BLOCK-----


code:
-----BEGIN PGP PUBLIC KEY BLOCK-----

mDMEXtVsNhYJKwYBBAHaRw8BAQdAnLsYdh3BpeK1xDguJE80XW2/MSmqeeP6pbQw
8jAw0OG0IkNoYXJsaWUgR3VpeCA8Y2hhcmxpZUBleGFtcGxlLm9yZz6IlgQTFggA
PhYhBKBDaY1jer75FlruS4IkDtyrgNqDBQJe1Ww2AhsDBQkDwmcABQsJCAcCBhUK
CQgLAgQWAgMBAh4BAheAAAoJEIIkDtyrgNqDM6cA/idDdoxo9SU+witdTXt24APH
yRzHbX9Iyh4dZNIek9JwAP9E0BwSvDHB4LY9z4RWf2hJp3dm/yZ/jEpK+w4BGN4J
Ag==
=JIU0
-----END PGP PUBLIC KEY BLOCK-----


code:
-----BEGIN PGP PRIVATE KEY BLOCK-----

lFgEXtVsNhYJKwYBBAHaRw8BAQdAnLsYdh3BpeK1xDguJE80XW2/MSmqeeP6pbQw
8jAw0OEAAP9lsLf3tk0OH1X4By4flYSz4PBFo40EwS4t6xx76poUphCEtCJDaGFy
bGllIEd1aXggPGNoYXJsaWVAZXhhbXBsZS5vcmc+iJYEExYIAD4WIQSgQ2mNY3q+
+RZa7kuCJA7cq4DagwUCXtVsNgIbAwUJA8JnAAULCQgHAgYVCgkICwIEFgIDAQIe
AQIXgAAKCRCCJA7cq4DagzOnAP4nQ3aMaPUlPsIrXU17duADx8kcx21/SMoeHWTS
HpPScAD/RNAcErwxweC2Pc+EVn9oSad3Zv8mf4xKSvsOARjeCQI=
=gUik
-----END PGP PRIVATE KEY BLOCK-----


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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-eggs)
  #:use-module (guix import egg)
  #:use-module (guix gexp)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module ((guix build syscalls) #:select (mkdtemp!))
  #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (web uri)
  #:use-module (ice-9 match))

(define test-egg-1
  '((synopsis "Example egg")
    (license "GPL-3/MIT")
    (version "1.0.0")
    (test-dependencies test srfi-1)
    (foreign-dependencies libgit2)
    (build-dependencies begin-syntax)
    (dependencies datatype)
    (author "John Doe")))

(define test-egg-2
  '((synopsis "Example egg")
    (license "GPL-3+")
    (version "0.3")
    (test-dependencies test)
    (foreign-dependencies libgit2)
    (build-dependencies begin-syntax)
    (dependencies datatype)
    (author "Alice Bobson")))

(define test-egg-1-file "/tmp/guix-egg-1")
(define test-egg-2-file "/tmp/guix-egg-2")

(test-begin "egg")

(test-equal "guix-package->egg-name"
  "bar"
  (guix-package->egg-name
   (dummy-package "dummy"
                  (name "chicken-bar"))))

;; Copied from tests/hackage.scm
(define-syntax-rule (define-package-matcher name pattern)
  (define* (name obj)
    (match obj
      (pattern #t)
      (x       (pk 'fail x #f)))))

(define (eval-test-with-egg-file egg-name egg-test egg-file matcher)
  (call-with-output-file egg-file
    (lambda (port)
      (write egg-test port)))
  (matcher (egg->guix-package egg-name
                              #:file egg-file
                              #:source (plain-file
                                        (string-append egg-name "-egg")
                                        "content"))))

(define-package-matcher match-chicken-foo
  ('package
    ('name "chicken-foo")
    ('version "1.0.0")
    ('source (? file-like? source))
    ('build-system 'chicken-build-system)
    ('arguments ('quasiquote ('#:egg-name "foo")))
    ('native-inputs
     ('quasiquote
      (("chicken-test" ('unquote chicken-test))
       ("chicken-srfi-1" ('unquote chicken-srfi-1))
       ("chicken-begin-syntax" ('unquote chicken-begin-syntax)))))
    ('inputs
     ('quasiquote
      (("libgit2" ('unquote libgit2)))))
    ('propagated-inputs
     ('quasiquote
      (("chicken-datatype" ('unquote chicken-datatype)))))
    ('home-page "https://wiki.call-cc.org/egg/foo")
    ('synopsis "Example egg")
    ('description #f)
    ('license '(list license:gpl3 license:expat))))

(define-package-matcher match-chicken-bar
  ('package
    ('name "chicken-bar")
    ('version "0.3")
    ('source (? file-like? source))
    ('build-system 'chicken-build-system)
    ('arguments ('quasiquote ('#:egg-name "bar")))
    ('native-inputs
     ('quasiquote
      (("chicken-test" ('unquote chicken-test))
       ("chicken-begin-syntax" ('unquote chicken-begin-syntax)))))
    ('inputs
     ('quasiquote
      (("libgit2" ('unquote libgit2)))))
    ('propagated-inputs
     ('quasiquote
      (("chicken-datatype" ('unquote chicken-datatype)))))
    ('home-page "https://wiki.call-cc.org/egg/bar")
    ('synopsis "Example egg")
    ('description #f)
    ('license 'license:gpl3+)))

(test-assert "egg->guix-package local file, multiple licenses"
  (eval-test-with-egg-file "foo" test-egg-1 test-egg-1-file match-chicken-foo))

(test-assert "egg->guix-package local file, single license"
  (eval-test-with-egg-file "bar" test-egg-2 test-egg-2-file match-chicken-bar))

(test-end "egg")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.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-elpa)
  #:use-module (guix import elpa)
  #:use-module (guix tests http)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (web client))

(define elpa-mock-archive
  '(1
    (ace-window .
                [(0 9 0)
                 ((avy
                   (0 2 0)))
                 "Quickly switch windows." single
                 ((:url . "https://github.com/abo-abo/ace-window")
                  (:keywords "window" "location"))])
    (auctex .
            [(11 88 6)
             nil "Integrated environment for *TeX*" tar
             ((:url . "http://www.gnu.org/software/auctex/"))])))

(test-begin "elpa")

(define (eval-test-with-elpa pkg)
  ;; Set up an HTTP server and use it as a pseudo-proxy so that
  ;; 'elpa->guix-package' talks to it.
  (with-http-server `((200 ,(object->string elpa-mock-archive))
                      (200 "This is the description.")
                      (200 "fake tarball contents"))
    (parameterize ((current-http-proxy (%local-url)))
      (match (elpa->guix-package pkg #:repo 'gnu/http)
        (('package
           ('name "emacs-auctex")
           ('version "11.88.6")
           ('source
            ('origin
              ('method 'url-fetch)
              ('uri ('string-append
                     "http://elpa.gnu.org/packages/auctex-" 'version ".tar"))
              ('sha256 ('base32 (? string? hash)))))
           ('build-system 'emacs-build-system)
           ('home-page "http://www.gnu.org/software/auctex/")
           ('synopsis "Integrated environment for *TeX*")
           ('description "This is the description.")
           ('license 'license:gpl3+))
         #t)
        (x
         (pk 'fail x #f))))))

(test-assert "elpa->guix-package test 1"
  (eval-test-with-elpa "auctex"))

(test-end "elpa")

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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-file-systems)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:use-module (gnu system file-systems)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

;; Test the (gnu system file-systems) module.

(test-begin "file-systems")

(test-assert "file-system-needed-for-boot?"
  (let-syntax ((dummy-fs (syntax-rules ()
                           ((_ directory)
                            (file-system
                              (device "foo")
                              (mount-point directory)
                              (type "ext4"))))))
    (parameterize ((%store-prefix "/gnu/guix/store"))
      (and (file-system-needed-for-boot? (dummy-fs "/"))
           (file-system-needed-for-boot? (dummy-fs "/gnu"))
           (file-system-needed-for-boot? (dummy-fs "/gnu/guix"))
           (file-system-needed-for-boot? (dummy-fs "/gnu/guix/store"))
           (not (file-system-needed-for-boot?
                 (dummy-fs "/gnu/guix/store/foo")))
           (not (file-system-needed-for-boot? (dummy-fs "/gn")))
           (not (file-system-needed-for-boot?
                 (file-system
                   (inherit (dummy-fs (%store-prefix)))
                   (device "/foo")
                   (flags '(bind-mount read-only)))))))))

(test-assert "does not pull (guix config)"
  ;; This module is meant both for the host side and "build side", so make
  ;; sure it doesn't pull in (guix config), which depends on the user's
  ;; config.
  (not (member '(guix config)
               (source-module-closure '((gnu system file-systems))))))

(test-equal "does not pull (gnu packages …)"
  ;; Same story: (gnu packages …) should not be pulled.
  #f
  (find (match-lambda
          (('gnu 'packages _ ..1) #t)
          (_ #f))
        (source-module-closure '((gnu system file-systems)))))

(test-equal "file-system-options->alist"
  '("autodefrag" ("subvol" . "home") ("compress" . "lzo"))
  (file-system-options->alist "autodefrag,subvol=home,compress=lzo"))

(test-equal "file-system-options->alist (#f)"
  '()
  (file-system-options->alist #f))

(test-equal "alist->file-system-options"
  "autodefrag,subvol=root,compress=lzo"
  (alist->file-system-options '("autodefrag"
                                ("subvol" . "root")
                                ("compress" . "lzo"))))

(test-equal "alist->file-system-options (null)"
  #f
  (alist->file-system-options '()))

;;;
;;; Btrfs related.
;;;

(define %btrfs-root-subvolume
  (file-system
    (device (file-system-label "btrfs-pool"))
    (mount-point "/")
    (type "btrfs")
    (options "subvol=rootfs,compress=zstd")))

(define %btrfs-store-subvolid
  (file-system
    (device (file-system-label "btrfs-pool"))
    (mount-point "/gnu/store")
    (type "btrfs")
    (options "subvolid=10,compress=zstd")
    (dependencies (list %btrfs-root-subvolume))))

(define %btrfs-store-subvolume
  (file-system
    (device (file-system-label "btrfs-pool"))
    (mount-point "/gnu/store")
    (type "btrfs")
    (options "subvol=/some/nested/file/name")
    (dependencies (list %btrfs-root-subvolume))))

(test-assert "btrfs-subvolume? (subvol)"
  (btrfs-subvolume? %btrfs-root-subvolume))

(test-assert "btrfs-subvolume? (subvolid)"
  (btrfs-subvolume? %btrfs-store-subvolid))

(test-equal "btrfs-store-subvolume-file-name"
  "/some/nested/file/name"
  (parameterize ((%store-prefix "/gnu/store"))
    (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
                                           %btrfs-store-subvolume))))

(test-error "btrfs-store-subvolume-file-name (subvolid)"
            (parameterize ((%store-prefix "/gnu/store"))
              (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
                                                     %btrfs-store-subvolid))))

(test-end)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; 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-gem)
  #:use-module (guix import gem)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module ((guix build utils) #:select (delete-file-recursively))
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define test-foo-json
  "{
  \"name\": \"foo\",
  \"version\": \"1.0.0\",
  \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
  \"info\": \"A cool gem\",
  \"homepage_uri\": \"https://example.com\",
  \"dependencies\": {
    \"runtime\": [
      { \"name\": \"bundler\" },
      { \"name\": \"bar\" }
    ]
  },
  \"licenses\": [\"MIT\", \"Apache 2.0\"]
}")

(define test-bar-json
  "{
  \"name\": \"bar\",
  \"version\": \"1.0.0\",
  \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
  \"info\": \"Another cool gem\",
  \"homepage_uri\": \"https://example.com\",
  \"dependencies\": {
    \"runtime\": [
      { \"name\": \"bundler\" }
    ]
  },
  \"licenses\": null
}")

(define test-bundler-json
  "{
  \"name\": \"bundler\",
  \"version\": \"1.14.2\",
  \"sha\": \"3bb53e03db0a8008161eb4c816ccd317120d3c415ba6fee6f90bbc7f7eec8690\",
  \"info\": \"Ruby gem bundler\",
  \"homepage_uri\": \"https://bundler.io/\",
  \"dependencies\": {
    \"runtime\": []
  },
  \"licenses\": [\"MIT\"]
}")

(test-begin "gem")

(test-assert "gem->guix-package"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v1/gems/foo.json"
              (values (open-input-string test-foo-json)
                      (string-length test-foo-json)))
             (_ (error "Unexpected URL: " url)))))
    (match (gem->guix-package "foo")
      (('package
         ('name "ruby-foo")
         ('version "1.0.0")
         ('source ('origin
                    ('method 'url-fetch)
                    ('uri ('rubygems-uri "foo" 'version))
                    ('sha256
                     ('base32
                      "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
         ('build-system 'ruby-build-system)
         ('propagated-inputs
          ('quasiquote
           (("bundler" ('unquote 'bundler))
            ("ruby-bar" ('unquote 'ruby-bar)))))
         ('synopsis "A cool gem")
         ('description "This package provides a cool gem")
         ('home-page "https://example.com")
         ('license ('list 'license:expat 'license:asl2.0)))
       #t)
      (x
       (pk 'fail x #f)))))

(test-assert "gem-recursive-import"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v1/gems/foo.json"
              (values (open-input-string test-foo-json)
                      (string-length test-foo-json)))
             ("https://rubygems.org/api/v1/gems/bar.json"
              (values (open-input-string test-bar-json)
                      (string-length test-bar-json)))
             ("https://rubygems.org/api/v1/gems/bundler.json"
              (values (open-input-string test-bundler-json)
                      (string-length test-bundler-json)))
             (_ (error "Unexpected URL: " url)))))
        (match (gem-recursive-import "foo")
          ((('package
              ('name "ruby-bar")
              ('version "1.0.0")
              ('source
               ('origin
                 ('method 'url-fetch)
                 ('uri ('rubygems-uri "bar" 'version))
                 ('sha256
                  ('base32
                   "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
              ('build-system 'ruby-build-system)
              ('propagated-inputs
               ('quasiquote
                (('"bundler" ('unquote 'bundler)))))
              ('synopsis "Another cool gem")
              ('description "Another cool gem")
              ('home-page "https://example.com")
              ('license #f))                      ;no licensing info
            ('package
              ('name "ruby-bundler")
              ('version "1.14.2")
              ('source
               ('origin
                 ('method 'url-fetch)
                 ('uri ('rubygems-uri "bundler" 'version))
                 ('sha256
                  ('base32
                   "1446xiz7zg0bz7kgx9jv84y0s4hpsg61dj5l3qb0i00avc1kxd9v"))))
              ('build-system 'ruby-build-system)
              ('synopsis "Ruby gem bundler")
              ('description "Ruby gem bundler")
              ('home-page "https://bundler.io/")
              ('license 'license:expat))
            ('package
              ('name "ruby-foo")
              ('version "1.0.0")
              ('source
               ('origin
                 ('method 'url-fetch)
                 ('uri ('rubygems-uri "foo" 'version))
                 ('sha256
                  ('base32
                   "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
              ('build-system 'ruby-build-system)
              ('propagated-inputs
               ('quasiquote
                (("bundler" ('unquote 'bundler))
                 ("ruby-bar" ('unquote 'ruby-bar)))))
              ('synopsis "A cool gem")
              ('description "This package provides a cool gem")
              ('home-page "https://example.com")
              ('license ('list 'license:expat 'license:asl2.0))))
           #t)
          (x
           (pk 'fail x #f)))))

(test-end "gem")