;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012-2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (unsetenv "http_proxy") (define-module (test-derivations) #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix utils) #:use-module ((gcrypt hash) #:prefix gcrypt:
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.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 (gnu build activation)
  #:use-module (gnu system accounts)
  #:use-module (gnu system privilege)
  #:use-module (gnu build accounts)
  #:use-module (gnu build linux-boot)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls) #:select (with-file-lock))
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (activate-users+groups
            activate-subuids+subgids
            activate-user-home
            activate-etc
            activate-privileged-programs
            activate-special-files
            activate-modprobe
            activate-firmware
            activate-ptrace-attach
            activate-current-system
            mkdir-p/perms))

;;; Commentary:
;;;
;;; This module provides "activation" helpers.  Activation is the process that
;;; consists in setting up system-wide files and directories so that an
;;; 'operating-system' configuration becomes active.
;;;
;;; Code:

(define %skeleton-directory
  ;; Directory containing skeleton files for new accounts.
  ;; Note: keep the trailing '/' so that 'scandir' enters it.
  "/etc/skel/")

(define (dot-or-dot-dot? file)
  (member file '("." "..")))

(define (mkdir-p/perms directory owner bits)
  "Create directory DIRECTORY and all its ancestors.

Additionally, verify no component of DIRECTORY is a symbolic link,
without TOCTTOU races.  However, if OWNER differs from the the current
(process) uid/gid, there is a small window in which DIRECTORY is set to the
current (process) uid/gid instead of OWNER.  This is not expected to be
a problem in practice.

The permission bits and owner of DIRECTORY are set to BITS and OWNER.
Anything above DIRECTORY that already exists keeps
its old owner and bits.  For components that do not exist yet, the owner
and bits are set according to the default behaviour of 'mkdir'."
  (define absolute?
    (string-prefix? "/" directory))

  (define not-slash
    (char-set-complement (char-set #\/)))

  ;; By combining O_NOFOLLOW and O_DIRECTORY, this procedure automatically
  ;; verifies that no components are symlinks.
  (define open-flags (logior O_CLOEXEC ; don't pass the port on to subprocesses
                             O_NOFOLLOW ; don't follow symlinks
                             O_DIRECTORY)) ; reject anything not a directory

  (let loop ((components (string-tokenize directory not-slash))
             (root (open (if absolute? "/" ".") open-flags)))
    (match components
      ((head tail ...)
       (let retry ()
         ;; In the usual case, we expect HEAD to already exist.
         (match (catch 'system-error
                  (lambda ()
                    (openat root head open-flags))
                  (lambda args
                    (if (= ENOENT (system-error-errno args))
                        #false
                        (begin
                          (close-port root)
                          (apply throw args)))))
           ((? port? new-root)
            (close root)
            (loop tail new-root))
           (#false
            ;; If not, create it.
            (catch 'system-error
              (lambda _
                (if (null? tail)
                    (mkdirat root head bits)
                    (mkdirat root head)))
              (lambda args
                ;; Someone else created the directory.  Unexpected but fine.
                (unless (= EEXIST (system-error-errno args))
                  (close-port root)
                  (apply throw args))))
            (retry)))))
      (()
       (catch 'system-error
         (lambda ()
           (chown root (passwd:uid owner) (passwd:gid owner))
           (chmod root bits))
         (lambda args
           (close-port root)
           (apply throw args)))
       (close-port root)
       (values)))))

(define* (copy-account-skeletons home
                                 #:key
                                 (directory %skeleton-directory)
                                 uid gid)
  "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
make it the owner of all the files created except the home directory; likewise
for GID."
  (define (set-owner file)
    (when (or uid gid)
      (chown file (or uid -1) (or gid -1))))

  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (mkdir-p home)
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (copy-recursively (string-append directory "/" file)
                                    target
                                    #:log (%make-void-port "w"))
                  (for-each set-owner
                            (find-files target (const #t)
                                        #:directories? #t))
                  (make-file-writable target)))
              files)))

(define* (make-skeletons-writable home
                                  #:optional (directory %skeleton-directory))
  "Make sure that the files that have been copied from DIRECTORY to HOME are
owner-writable in HOME."
  (let ((files (scandir directory (negate dot-or-dot-dot?)
                        string<?)))
    (for-each (lambda (file)
                (let ((target (string-append home "/" file)))
                  (when (file-exists? target)
                    (make-file-writable target))))
              files)))

(define (duplicates lst)
  "Return elements from LST present more than once in LST."
  (let loop ((lst lst)
             (seen vlist-null)
             (result '()))
    (match lst
      (()
       (reverse result))
      ((head . tail)
       (loop tail
             (vhash-cons head #t seen)
             (if (vhash-assoc head seen)
                 (cons head result)
                 result))))))

(define (activate-users+groups users groups)
  "Make sure USERS (a list of user account records) and GROUPS (a list of user
group records) are all available."
  (define (make-home-directory user)
    (let ((home (user-account-home-directory user))
          (pwd  (getpwnam (user-account-name user))))
      (mkdir-p home)

      ;; Always set ownership and permissions for home directories of system
      ;; accounts.  If a service needs looser permissions on its home
      ;; directories, it can always chmod it in an activation snippet.
      (chown home (passwd:uid pwd) (passwd:gid pwd))
      (chmod home #o700)))

  (define system-accounts
    (filter (lambda (user)
              (and (user-account-system? user)
                   (user-account-create-home-directory? user)))
            users))

  ;; Allow home directories to be created under /var/lib.
  (mkdir-p "/var/lib")

  ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
  ;; and write the databases.  This ensures there's no race condition with
  ;; other tools that might be accessing it at the same time.
  (with-file-lock %password-lock-file
    (let-values (((groups passwd shadow)
                  (user+group-databases users groups)))
      (write-group groups)
      (write-passwd passwd)
      (write-shadow shadow)))

  ;; Home directories of non-system accounts are created by
  ;; 'activate-user-home'.
  (for-each make-home-directory system-accounts)

  ;; Turn shared home directories, such as /var/empty, into root-owned,
  ;; read-only places.
  (for-each (lambda (directory)
              (chown directory 0 0)
              (chmod directory #o555))
            (duplicates (map user-account-home-directory system-accounts))))

(define (activate-subuids+subgids subuids subgids)
  "Make sure SUBUIDS (a list of subid range records) and SUBGIDS (a list of
subid range records) are all available."

  ;; Take same lock as Shadow while we read
  ;; and write the databases.  This ensures there's no race condition with
  ;; other tools that might be accessing it at the same time.
  (with-file-lock "/etc/subgid.lock"
    (let-values (((subuid subgid)
                  (subuid+subgid-databases subuids subgids)))
      (write-subgid subgid)))

  (with-file-lock "/etc/subuid.lock"
    (let-values (((subuid subgid)
                  (subuid+subgid-databases subuids subgids)))
      (write-subuid subuid))))

(define (activate-user-home users)
  "Create and populate the home directory of USERS, a list of tuples, unless
they already exist."
  (define ensure-user-home
    (lambda (user)
      (let ((name         (user-account-name user))
            (home         (user-account-home-directory user))
            (create-home? (user-account-create-home-directory? user))
            (system?      (user-account-system? user)))
        ;; The home directories of system accounts are created during
        ;; activation, not here.
        (unless (or (not home) (not create-home?) system?
                    (directory-exists? home))
          (let* ((pw  (getpwnam name))
                 (uid (passwd:uid pw))
                 (gid (passwd:gid pw)))
            (mkdir-p home)
            (chmod home #o700)
            (copy-account-skeletons home
                                    #:uid uid #:gid gid)

            ;; It is important 'chown' be called after
            ;; 'copy-account-skeletons'.  Otherwise, a malicious user with
            ;; good timing could create a symlink in HOME that would be
            ;; dereferenced by 'copy-account-skeletons'.
            (chown home uid gid))))))

  (for-each ensure-user-home users))

(define (activate-etc etc)
  "Install ETC, a directory in the store, as the source of static files for
/etc."

  ;; /etc is a mixture of static and dynamic settings.  Here is where we
  ;; initialize it from the static part.

  (define (rm-f file)
    (false-if-exception (delete-file file)))

  (format #t "populating /etc from ~a...~%" etc)
  (mkdir-p "/etc")

  ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
  ;; symlink, to a target outside of the store, probably doesn't belong in the
  ;; static 'etc' store directory.  However, if it were to be put there,
  ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
  ;; time of activation (e.g. when installing a fresh system), the call to
  ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
  (rm-f "/etc/ssl")
  (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")

  (rm-f "/etc/static")
  (symlink etc "/etc/static")
  (for-each (lambda (file)
              (let ((target (string-append "/etc/" file))
                    (source (string-append "/etc/static/" file)))
                (rm-f target)

                ;; Things such as /etc/sudoers must be regular files, not
                ;; symlinks; furthermore, they could be modified behind our
                ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
                ;; symlinking them.
                (if (file-is-directory? source)
                    (symlink source target)
                    (copy-file source target))

                ;; XXX: Dirty hack to meet sudo's expectations.
                (when (string=? (basename target) "sudoers")
                  (chmod target #o440))))
            (scandir etc (negate dot-or-dot-dot?)

                     ;; The default is 'string-locale<?', but we don't have
                     ;; it when run from the initrd's statically-linked
                     ;; Guile.
                     string<?)))

(define %setuid-directory
  ;; Place where setuid programs used to be stored.  It exists for backwards
  ;; compatibility & will be removed.  Use %PRIVILEGED-PROGRAM-DIRECTORY instead.
  "/run/setuid-programs")

(define %privileged-program-directory
  ;; Place where privileged copies of programs are stored.
  "/run/privileged/bin")

(define (activate-privileged-programs programs libcap)
  "Turn PROGRAMS, a list of file privileged-programs records, into privileged
copies stored under %PRIVILEGED-PROGRAM-DIRECTORY, using LIBCAP's setcap(8)
binary if needed."
  (define (ensure-empty-directory directory)
    (if (file-exists? directory)
        (for-each (compose delete-file
                           (cut string-append directory "/" <>))
                  (scandir directory
                           (lambda (file)
                             (not (member file '("." ".."))))
                           string<?))
        (mkdir-p directory))    )

  (define (make-privileged-program program setuid? setgid? uid gid capabilities)
    (let ((target (string-append %privileged-program-directory
                                 "/" (basename program)))
          (mode (+ #o0555                   ; base permissions
                   (if setuid? #o4000 0)    ; setuid bit
                   (if setgid? #o2000 0)))) ; setgid bit
      (copy-file program target)
      (chown target uid gid)
      (chmod target mode)
      (when (and capabilities libcap)
        (system* (string-append libcap "/sbin/setcap")
                 "-q" capabilities target))))

  (define (make-deprecated-wrapper program)
    ;; This will eventually become a script that warns on usage, then vanish.
    (symlink (string-append %privileged-program-directory
                            "/" (basename program))
             (string-append %setuid-directory
                            "/" (basename program))))

  (format #t "setting up privileged programs in '~a'...~%"
          %privileged-program-directory)
  (ensure-empty-directory %privileged-program-directory)
  (ensure-empty-directory %setuid-directory)

  (for-each (lambda (program)
              (catch 'system-error
                (lambda ()
                  (let* ((program-name (privileged-program-program program))
                         (setuid?      (privileged-program-setuid? program))
                         (setgid?      (privileged-program-setgid? program))
                         (user         (privileged-program-user program))
                         (group        (privileged-program-group program))
                         (capabilities (privileged-program-capabilities program))
                         (uid (match user
                                ((? string?) (passwd:uid (getpwnam user)))
                                ((? integer?) user)))
                         (gid (match group
                                ((? string?) (group:gid (getgrnam group)))
                                ((? integer?) group))))
                    (make-privileged-program program-name
                                             setuid? setgid? uid gid
                                             capabilities)
                    (make-deprecated-wrapper program-name)))
                (lambda args
                  ;; If we fail to create a privileged program, better keep going
                  ;; so that we don't leave %PRIVILEGED-PROGRAM-DIRECTORY empty
                  ;; or half-populated.  This can happen if PROGRAMS contains
                  ;; incorrect file names: <https://bugs.gnu.org/38800>.
                  (format (current-error-port)
                          "warning: failed to privilege ~s: ~a~%"
                          (privileged-program-program program)
                          (strerror (system-error-errno args))))))
            programs))

(define (activate-special-files special-files)
  "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
is a pair where the first element is the name of the special file and the
second element is the name it should appear at, such as:

  ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
   (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
"
  (define install-special-file
    (match-lambda
      ((target file)
       (let ((pivot (string-append target ".new")))
         (mkdir-p (dirname target))
         (symlink file pivot)
         (rename-file pivot target)))))

  (for-each install-special-file special-files))

(define (activate-modprobe modprobe)
  "Tell the kernel to use MODPROBE to load modules."

  ;; If the kernel was built without loadable module support, this file is
  ;; unavailable, so check for its existence first.
  (when (file-exists? "/proc/sys/kernel/modprobe")
    (call-with-output-file "/proc/sys/kernel/modprobe"
      (lambda (port)
        (display modprobe port)))))

(define (activate-firmware directory)
  "Tell the kernel to look for device firmware under DIRECTORY.  This
mechanism bypasses udev: it allows Linux to handle firmware loading directly
by itself, without having to resort to a \"user helper\"."

  ;; If the kernel was built without firmware loading support, this file
  ;; does not exist.  Do nothing in that case.
  (let ((firmware-path "/sys/module/firmware_class/parameters/path"))
    (when (file-exists? firmware-path)
      (call-with-output-file firmware-path
        (lambda (port)
          (display directory port))))))

(define (activate-ptrace-attach)
  "Allow users to PTRACE_ATTACH their own processes.

This works around a regression introduced in the default \"security\" policy
found in Linux 3.4 onward that prevents users from attaching to their own
processes--see Yama.txt in the Linux source tree for the rationale.  This
sounds like an unacceptable restriction for little or no security
improvement."
  (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
    (when (file-exists? file)
      (call-with-output-file file
        (lambda (port)
          (display 0 port))))))


(define %current-system
  ;; The system that is current (a symlink.)  This is not necessarily the same
  ;; as the system we booted (aka. /run/booted-system) because we can re-build
  ;; a new system configuration and activate it, without rebooting.
  "/run/current-system")

(define (boot-time-system)
  "Return the 'gnu.system' argument passed on the kernel command line."
  (find-long-option "gnu.system" (if (string-contains %host-type "linux-gnu")
                                   (linux-command-line)
                                   (command-line))))

(define* (activate-current-system
          #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
                                 (boot-time-system))))
  "Atomically make SYSTEM the current system."
  ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
  ;; system reconfigure' to pass the file name of the new system.

  (format #t "making '~a' the current system...~%" system)

  (mkdir-p "/run")
  ;; Atomically make SYSTEM current.
  (let ((new (string-append %current-system ".new")))
    (symlink system new)
    (rename-file new %current-system)))

;;; activation.scm ends here
generated by cgit
h (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 . (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 drv)) (memq drv (list fixed1 fixed2))))))) (test-assert "derivation with equivalent fixed-output inputs" ;; Similar as the test above, but indirectly: DRV3A and DRV3B below are ;; equivalent derivations (same output paths) but they depend on ;; different-but-equivalent fixed-output derivations. Thus, DRV3A and DRV3B ;; must be coalesced as inputs of DRV4. See . (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh" "echo -n hello > $out" '())) (builder2 (add-text-to-store %store "fixed-builder2.sh" "echo -n hello > $out" '())) (builder3 (add-text-to-store %store "user-builder.sh" "echo 1 > $one; echo 2 > $two" '())) (hash (gcrypt:sha256 (string->utf8 "hello"))) (drv1 (derivation %store "fixed" %bash (list builder1) #:sources (list builder1) #:hash hash #:hash-algo 'sha256)) (drv2 (derivation %store "fixed" %bash (list builder2) #:sources (list builder2) #:hash hash #:hash-algo 'sha256)) (drv3a (derivation %store "fixed-user" %bash (list builder3) #:outputs '("one" "two") #:sources (list builder3) #:inputs (list (derivation-input drv1)))) (drv3b (derivation %store "fixed-user" %bash (list builder3) #:outputs '("one" "two") #:sources (list builder3) #:inputs (list (derivation-input drv2)))) (drv4 (derivation %store "fixed-user-user" %bash (list builder1) #:sources (list builder1) #:inputs (list (derivation-input drv3a '("one")) (derivation-input drv3b '("two")))))) (match (derivation-inputs drv4) ((input) (and (memq (derivation-input-derivation input) (list drv3a drv3b)) (lset= string=? (derivation-input-sub-derivations input) '("one" "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 "read-derivation with hash = #f" ;; Passing #:hash-algo together with #:hash #f is accepted and #:hash-algo ;; is preserved. However it is not a fixed-output derivation. It used to ;; be that 'read-derivation' would incorrectly return #vu8() instead of #f ;; for the hash in this case: ;; . (let* ((drv1 (derivation %store "almost-fixed-output" "builtin:download" '() #:env-vars `(("url" . "http://example.org")) #:hash-algo 'sha256 #:hash #f)) (drv2 (call-with-input-file (derivation-file-name drv1) read-derivation))) (and (not (eq? drv1 drv2)) ;ensure memoization doesn't kick in (equal? drv1 drv2)))) (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? 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 $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-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-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 . (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-equal "derivation-build-plan, topological ordering" (make-list 5 '("0.drv" "1.drv" "2.drv" "3.drv" "4.drv")) (with-store store (define (test _) (let* ((simple-derivation (lambda (name . deps) (build-expression->derivation store name `(begin ,(random-text) (mkdir %output)) #:inputs (map (lambda (n dep) (list (number->string n) dep)) (iota (length deps)) deps)))) (drv0 (simple-derivation "0")) (drv1 (simple-derivation "1" drv0)) (drv2 (simple-derivation "2" drv1)) (drv3 (simple-derivation "3" drv2 drv0)) (drv4 (simple-derivation "4" drv3 drv1))) (map (compose strip-store-file-name derivation-file-name) (derivation-build-plan store (list (derivation-input drv4)))))) ;; This is probabilistic: if the traversal is buggy, it may or may not ;; produce the wrong ordering, depending on a variety of actors. Thus, ;; try multiple times. (map test (iota 5)))) (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 stringderivation %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: