aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;;
;;; 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 bootloader)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (guix discovery)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (guix deprecation)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point
            menu-entry-multiboot-kernel
            menu-entry-multiboot-arguments
            menu-entry-multiboot-modules
            menu-entry-chain-loader

            menu-entry->sexp
            sexp->menu-entry

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-disk-image-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target ;deprecated
            bootloader-configuration-targets
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-keyboard-layout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-device-tree-support?
            bootloader-configuration-extra-initrd

            %bootloaders
            lookup-bootloader-by-name

            efi-bootloader-chain))


;;;
;;; Menu-entry record.
;;;

(define-record-type* <menu-entry>
  menu-entry make-menu-entry
  menu-entry?
  (label           menu-entry-label)
  (device          menu-entry-device       ; file system uuid, label, or #f
                   (default #f))
  (device-mount-point menu-entry-device-mount-point
                   (default #f))
  (linux           menu-entry-linux
                   (default #f))
  (linux-arguments menu-entry-linux-arguments
                   (default '()))          ; list of string-valued gexps
  (initrd          menu-entry-initrd       ; file name of the initrd as a gexp
                   (default #f))
  (multiboot-kernel menu-entry-multiboot-kernel
                    (default #f))
  (multiboot-arguments menu-entry-multiboot-arguments
                       (default '()))      ; list of string-valued gexps
  (multiboot-modules menu-entry-multiboot-modules
                     (default '()))        ; list of multiboot commands, where
                                           ; a command is a list of <string>
  (chain-loader     menu-entry-chain-loader
                    (default #f)))         ; string, path of efi file

(define (report-menu-entry-error menu-entry)
  (raise
   (condition
    (&message
     (message
      (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
    (&fix-hint
     (hint
      (G_ "Please chose only one of:
@enumerate
@item direct boot by specifying fields @code{linux},
@code{linux-arguments} and @code{linux-modules},
@item multiboot by specifying fields @code{multiboot-kernel},
@code{multiboot-arguments} and @code{multiboot-modules},
@item chain-loader by specifying field @code{chain-loader}.
@end enumerate"))))))

(define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
  (define (device->sexp device)
    (match device
      ((? uuid? uuid)
       `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
      ((? file-system-label? label)
       `(label ,(file-system-label->string label)))
      (_ device)))
  (match entry
    (($ <menu-entry> label device mount-point
                     (? identity linux) linux-arguments (? identity initrd)
                     #f () () #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))
    (($ <menu-entry> label device mount-point #f () #f
                     (? identity multiboot-kernel) multiboot-arguments
                     multiboot-modules #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (multiboot-kernel ,multiboot-kernel)
                  (multiboot-arguments ,multiboot-arguments)
                  (multiboot-modules ,multiboot-modules)))
    (($ <menu-entry> label device mount-point #f () #f #f () ()
                     (? identity chain-loader))
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (chain-loader ,chain-loader)))
    (_ (report-menu-entry-error entry))))

(define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
  (define (sexp->device device-sexp)
    (match device-sexp
      (('uuid type uuid-string)
       (uuid uuid-string type))
      (('label label)
       (file-system-label label))
      (_ device-sexp)))
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('linux linux) ('linux-arguments linux-arguments)
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
      (initrd initrd)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('multiboot-kernel multiboot-kernel)
                  ('multiboot-arguments multiboot-arguments)
                  ('multiboot-modules multiboot-modules) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (multiboot-kernel multiboot-kernel)
      (multiboot-arguments multiboot-arguments)
      (multiboot-modules multiboot-modules)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('chain-loader chain-loader) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (chain-loader chain-loader)))))


;;;
;;; Bootloader record.
;;;

;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.

(define-record-type* <bootloader>
  bootloader make-bootloader
  bootloader?
  (name                            bootloader-name)
  (package                         bootloader-package)
  (installer                       bootloader-installer)
  (disk-image-installer            bootloader-disk-image-installer
                                   (default #f))
  (configuration-file              bootloader-configuration-file)
  (configuration-file-generator    bootloader-configuration-file-generator))


;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-with-syntax-properties (warn-target-field-deprecation
                                (value properties))
  (when value
    (warning (source-properties->location properties)
             (G_ "the 'target' field is deprecated, please use 'targets' \
instead~%")))
  value)

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader
   bootloader-configuration-bootloader) ;<bootloader>
  (targets               %bootloader-configuration-targets
                         (default #f))     ;list of strings
  (target                %bootloader-configuration-target ;deprecated
                         (default #f)
                         (sanitize warn-target-field-deprecation))
  (menu-entries          bootloader-configuration-menu-entries
                         (default '()))   ;list of <menu-entry>
  (default-entry         bootloader-configuration-default-entry
                         (default 0))     ;integer
  (timeout               bootloader-configuration-timeout
                         (default 5))     ;seconds as integer
  (keyboard-layout       bootloader-configuration-keyboard-layout
                         (default #f))    ;<keyboard-layout> | #f
  (theme                 bootloader-configuration-theme
                         (default #f))    ;bootloader-specific theme
  (terminal-outputs      bootloader-configuration-terminal-outputs
                         (default '(gfxterm)))   ;list of symbols
  (terminal-inputs       bootloader-configuration-terminal-inputs
                         (default '()))   ;list of symbols
  (serial-unit           bootloader-configuration-serial-unit
                         (default #f))    ;integer | #f
  (serial-speed          bootloader-configuration-serial-speed
                         (default #f))    ;integer | #f
  (device-tree-support?  bootloader-configuration-device-tree-support?
                         (default #t))    ;boolean
  (extra-initrd          bootloader-configuration-extra-initrd
                         (default #f)))   ;string | #f

(define-deprecated (bootloader-configuration-target config)
  bootloader-configuration-targets
  (%bootloader-configuration-target config))

(define (bootloader-configuration-targets config)
  (or (%bootloader-configuration-targets config)
      ;; TODO: Remove after the deprecated 'target' field is removed.
      (list (%bootloader-configuration-target config))
      ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
      ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
      ;; hence the default value of '(#f) rather than '().
      (list #f)))


;;;
;;; Bootloaders.
;;;

(define (bootloader-modules)
  "Return the list of bootloader modules."
  (all-modules (map (lambda (entry)
                      `(,entry . "gnu/bootloader"))
                    %load-path)
               #:warn warn-about-load-error))

(define %bootloaders
  ;; The list of publically-known bootloaders.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (bootloader? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (bootloader-modules))))

(define (lookup-bootloader-by-name name)
  "Return the bootloader called NAME."
  (or (find (lambda (bootloader)
              (eq? name (bootloader-name bootloader)))
            (force %bootloaders))
      (leave (G_ "~a: no such bootloader~%") name)))

(define (efi-bootloader-profile packages files hooks)
  "Creates a profile from the lists of PACKAGES and FILES from the store.
This profile is meant to be used by the bootloader-installer.

FILES is a list of file or directory names from the store, which will be
symlinked into the profile.  If a directory name ends with '/', then the
directory content instead of the directory itself will be symlinked into the
profile.

FILES may contain file like objects produced by procedures like plain-file,
local-file, etc., or package contents produced with file-append.

HOOKS lists additional hook functions to modify the profile."
  (define* (efi-bootloader-profile-hook manifest #:optional system)
    (define build
        (with-imported-modules '((guix build utils))
          #~(begin
            (use-modules ((guix build utils)
                          #:select (mkdir-p strip-store-file-name))
                         ((ice-9 ftw)
                          #:select (scandir))
                         ((srfi srfi-1)
                          #:select (append-map every remove))
                         ((srfi srfi-26)
                          #:select (cut)))
            (define (symlink-to file directory transform)
              "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
              (symlink file (string-append directory "/" (transform file))))
            (define (directory-content directory)
              "Creates a list of absolute path names inside DIRECTORY."
              (map (lambda (name)
                     (string-append directory name))
                   (or (scandir directory (lambda (name)
                                            (not (member name '("." "..")))))
                       '())))
            (define name-ends-with-/? (cut string-suffix? "/" <>))
            (define (name-is-store-entry? name)
              "Return #t if NAME is a direct store entry and nothing inside."
              (not (string-index (strip-store-file-name name) #\/)))
            (let* ((files '#$files)
                   (directories (filter name-ends-with-/? files))
                   (names-from-directories
                    (append-map (lambda (directory)
                                  (directory-content directory))
                                directories))
                   (names (append names-from-directories
                                  (remove name-ends-with-/? files))))
              (mkdir-p #$output)
              (if (every file-exists? names)
                  (begin
                    (for-each (lambda (name)
                               (symlink-to name #$output
                                            (if (name-is-store-entry? name)
                                                strip-store-file-name
                                                basename)))
                              names)
                    #t)
                  #f)))))

    (gexp->derivation "efi-bootloader-profile"
                      build
                      #:system system
                      #:local-build? #t
                      #:substitutable? #f
                      #:properties
                      `((type . profile-hook)
                        (hook . efi-bootloader-profile-hook))))

  (profile (content (packages->manifest packages))
           (name "efi-bootloader-profile")
           (hooks (cons efi-bootloader-profile-hook hooks))
           (locales? #f)
           (allow-collisions? #f)
           (relative-symlinks? #f)))

(define* (efi-bootloader-chain final-bootloader
                               #:key
                               (packages '())
                               (files '())
                               (hooks '())
                               installer
                               disk-image-installer)
  "Define a chain of bootloaders with the FINAL-BOOTLOADER, optional PACKAGES,
and optional directories and files from the store given in the list of FILES.

The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be placed
in an efi-bootloader-profile, which will be passed to the INSTALLER.

FILES may contain file-like objects produced by procedures like plain-file,
local-file, etc., or package contents produced with file-append.

If a directory name in FILES ends with '/', then the directory content instead
of the directory itself will be symlinked into the efi-bootloader-profile.

The procedures in the HOOKS list can be used to further modify the bootloader
profile.  It is possible to pass a single function instead of a list.

If the INSTALLER argument is used, then this gexp procedure will be called to
install the efi-bootloader-profile.  Otherwise the installer of the
FINAL-BOOTLOADER will be called.

If the DISK-IMAGE-INSTALLER is used, then this gexp procedure will be called
to install the efi-bootloader-profile into a disk image.  Otherwise the
disk-image-installer of the FINAL-BOOTLOADER will be called."
  (bootloader
    (inherit final-bootloader)
    (name 'efi-bootloader-chain)
    (package
     (efi-bootloader-profile (cons (bootloader-package final-bootloader)
                                   packages)
                             files
                             (if (list? hooks)
                                 hooks
                                 (list hooks))))
    (installer
     (or installer
         (bootloader-installer final-bootloader)))
    (disk-image-installer
     (or disk-image-installer
         (bootloader-disk-image-installer final-bootloader)))))
generated by cgit
; "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-assert "fixed-output-derivation?, no hash" ;; A derivation that has #:hash-algo and #:hash #f is *not* fixed-output. (let* ((drv (derivation %store "not-quite-fixed" "builtin:download" '() #:hash #f #:hash-algo 'sha256))) (not (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 "fixed-output derivation, invalid hash size" (guard (c ((store-protocol-error? c) (string-contains-ci (store-protocol-error-message c) "invalid SHA512 hash"))) (derivation %store "download-with-invalid-hash" "builtin:download" '() #:env-vars `(("url" . ,(object->string "http://example.org"))) #:hash-algo 'sha512 #:hash #vu8(1 2 3)) #f)) (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 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 <https://bugs.gnu.org/54209>. (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: ;; <https://lists.gnu.org/archive/html/guix-devel/2023-01/msg00040.html>. (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<?) "\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-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 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:
generated by cgit