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

#
# Test the daemon and its interaction with 'guix substitute'.
#

set -e

guix-daemon --version
guix build --version

drv="`guix build emacs -d`"
out="`guile -c '								\
  (use-modules (guix) (gnu packages emacs))					\
  (define store (open-connection))						\
  (%graft? #f)
  (display (derivation->output-path (package-derivation store emacs)))'`"

hash_part="`basename $out | cut -c 1-32`"
narinfo="$hash_part.narinfo"
substitute_dir="`echo $GUIX_BINARY_SUBSTITUTE_URL | sed -'es,file://,,g'`"

cat > "$substitute_dir/nix-cache-info"<<EOF
StoreDir: `dirname $drv`
WantMassQuery: 0
EOF

cat > "$substitute_dir/$narinfo"<<EOF
StorePath: $out
URL: /nowhere/example.nar
Compression: none
NarSize: 1234
References: 
System: `guile -c '(use-modules (guix)) (display (%current-system))'`
Deriver: $drv
EOF

# Remove the cached narinfo.
rm -f "$XDG_CACHE_HOME/guix/substitute/$hash_part"

# Make sure we see the substitute.
guile -c "
  (use-modules (guix))
  (define store (open-connection))
  (set-build-options store #:use-substitutes? #t
                     #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))
  (exit (has-substitutes? store \"$out\"))"

# Now, run guix-daemon --no-substitutes.
socket="$GUIX_STATE_DIRECTORY/alternate-socket"
guix-daemon --no-substitutes --listen="$socket" --disable-chroot &
daemon_pid=$!
trap 'kill $daemon_pid' EXIT

# Make sure we DON'T see the substitute.
guile -c "
  (use-modules (guix))
  (define store (open-connection \"$socket\"))

  ;; This setting MUST NOT override the daemon's --no-substitutes.
  (set-build-options store #:use-substitutes? #t
                     #:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))

  (exit (not (has-substitutes? store \"$out\")))"

kill "$daemon_pid"

# Pass several '--listen' options, and make sure they are all honored.
guix-daemon --disable-chroot --listen="$socket" --listen="$socket-second" \
	    --listen="localhost" --listen="localhost:9876" &
daemon_pid=$!

for uri in "$socket" "$socket-second" \
		     "guix://localhost" "guix://localhost:9876"
do
    GUIX_DAEMON_SOCKET="$uri" guix build guile-bootstrap
done

kill "$daemon_pid"

# Make sure 'profiles/per-user' is created when connecting over TCP.

orig_GUIX_STATE_DIRECTORY="$GUIX_STATE_DIRECTORY"
GUIX_STATE_DIRECTORY="$GUIX_STATE_DIRECTORY-2"

guix-daemon --disable-chroot --listen="localhost:9877" &
daemon_pid=$!

GUIX_DAEMON_SOCKET="guix://localhost:9877"
export GUIX_DAEMON_SOCKET

test ! -d "$GUIX_STATE_DIRECTORY/profiles/per-user"

guix build guile-bootstrap -d

test -d "$GUIX_STATE_DIRECTORY/profiles/per-user/$USER"

kill "$daemon_pid"
unset GUIX_DAEMON_SOCKET
GUIX_STATE_DIRECTORY="$orig_GUIX_STATE_DIRECTORY"

# Check the failed build cache.

guix-daemon --no-substitutes --listen="$socket" --disable-chroot	\
  --cache-failures &
daemon_pid=$!

guile -c "
  (use-modules (guix) (guix tests) (srfi srfi-34))
  (define store (open-connection-for-tests \"$socket\"))

  ;; Disable grafts to avoid building more than needed.
  (%graft? #f)

  (define (build-without-failing drv)
    (lambda (store)
      (guard (c ((store-protocol-error? c) (values #t store)))
        (build-derivations store (list drv))
        (values #f store))))

  ;; Make sure failed builds are cached and can be removed from
  ;; the cache.
  (run-with-store store
    (mlet* %store-monad ((drv (gexp->derivation \"failure\"
                                                #~(begin
                                                    (ungexp output)
                                                     #f)))
                         (out -> (derivation->output-path drv))
                         (ok?    (build-without-failing drv)))
      ;; Note the mixture of monadic and direct style.  Don't try
      ;; this at home!
      (return (exit (and ok?
                         (equal? (query-failed-paths store) (list out))
                         (begin
                           (clear-failed-paths store (list out))
                           (null? (query-failed-paths store)))))))
    #:guile-for-build (%guile-for-build)) "

kill "$daemon_pid"


# Make sure the daemon's default 'build-cores' setting is honored.

guix-daemon --listen="$socket" --disable-chroot --cores=42 &
daemon_pid=$!

GUIX_DAEMON_SOCKET="$socket" \
guile -c '
  (use-modules (guix) (guix tests))

  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "echo $NIX_BUILD_CORES > $out"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv    (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text))))))
      (and (build-derivations store (list drv))
           (exit
            (= 42 (pk (call-with-input-file (derivation->output-path drv)
                        read)))))))'


kill "$daemon_pid"

# Make sure the daemon's default 'timeout' and 'max-silent-time' settings are
# honored.

client_code='
  (use-modules (guix) (guix tests) (srfi srfi-34))

  (with-store store
    (let* ((build  (add-text-to-store store "build.sh"
                                      "while true ; do : ; done"))
           (bash   (add-to-store store "bash" #t "sha256"
                                 (search-bootstrap-binary "bash"
                                                          (%current-system))))
           (drv    (derivation store "the-thing" bash
                               `("-e" ,build)
                               #:inputs `((,bash) (,build))
                               #:env-vars `(("x" . ,(random-text))))))
      (exit (guard (c ((store-protocol-error? c)
                       (->bool
                        (string-contains (pk (store-protocol-error-message c))
                                         "failed"))))
              (build-derivations store (list drv))
              #f))))'


for option in --max-silent-time=1 --timeout=1
do
    guix-daemon --listen="$socket" --disable-chroot "$option" &
    daemon_pid=$!

    GUIX_DAEMON_SOCKET="$socket" guile -c "$client_code"
    kill "$daemon_pid"
done

# Make sure garbage collection from a TCP connection does not work.

tcp_socket="127.0.0.1:9998"
guix-daemon --listen="$tcp_socket" &
daemon_pid=$!

GUIX_DAEMON_SOCKET="guix://$tcp_socket"
export GUIX_DAEMON_SOCKET

guix gc && false

unset GUIX_DAEMON_SOCKET
kill "$daemon_pid"

# Log compression.

guix-daemon --listen="$socket" --disable-chroot --debug --log-compression=gzip &
daemon_pid=$!

stamp="compressed-build-log-test-$$-`date +%H%M%S`"
client_code="
  (use-modules (guix) (gnu packages bootstrap))

  (with-store store
    (run-with-store store
      (mlet %store-monad ((drv (lower-object
				(computed-file \"compressed-log-test\"
					       #~(begin
						   (display \"$stamp\")
                                                   (newline)
						   (mkdir #\$output))
					       #:guile %bootstrap-guile))))
	(display (derivation-file-name drv))
	(newline)
	(return #t))))
"

GUIX_DAEMON_SOCKET="$socket"
export GUIX_DAEMON_SOCKET

drv=`guile -c "$client_code"`
guix build "$drv"

log=`guix build "$drv" --log-file`
test -f "$log"
case "$log" in
    *.gz) test "`gunzip -c < "$log"`" = "$stamp" ;;
    *)    false ;;
esac
generated by cgit
ut))) inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (let* ((graphs '#$(match inputs (((names . _) ...) names))) (initialize (root-partition-initializer #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:system-directory #$os-drv)) (root-size #$(if (eq? 'guess disk-image-size) #~(estimated-partition-size (map (cut string-append "/xchg/" <>) graphs)) (- disk-image-size (* 50 (expt 2 20))))) (partitions (list (partition (size root-size) (label #$file-system-label) (file-system #$file-system-type) (flags '(boot)) (initializer initialize)) ;; Append a small EFI System Partition for ;; use with UEFI bootloaders. (partition ;; The standalone grub image is about 10MiB, but ;; leave some room for custom or multiple images. (size (* 40 (expt 2 20))) (label "GNU-ESP") ;cosmetic only ;; Use "vfat" here since this property is used ;; when mounting. The actual FAT-ness is based ;; on filesystem size (16 in this case). (file-system "vfat") (flags '(esp)))))) (initialize-hard-disk "/dev/vda" #:partitions partitions #:grub-efi #$grub-efi #:bootloader-package #$(bootloader-package bootloader) #:bootcfg #$bootcfg-drv #:bootcfg-location #$(bootloader-configuration-file bootloader) #:bootloader-installer #$(bootloader-installer bootloader)) (reboot))))) #:system system #:make-disk-image? #t #:disk-image-size disk-image-size #:disk-image-format disk-image-format #:references-graphs inputs)) ;;; ;;; VM and disk images. ;;; (define* (system-disk-image os #:key (name "disk-image") (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20))) (volatile? #t)) "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the system described by OS. Said image can be copied on a USB stick as is. When VOLATILE? is true, the root file system is made volatile; this is useful to USB sticks meant to be read-only." (define normalize-label ;; ISO labels are all-caps (case-insensitive), but since ;; 'find-partition-by-label' is case-sensitive, make it all-caps here. (if (string=? "iso9660" file-system-type) string-upcase identity)) (define root-label ;; Volume name of the root file system. Since we don't know which device ;; will hold it, we use the volume name to find it (using the UUID would ;; be even better, but somewhat less convenient.) (normalize-label "GuixSD_image")) (define file-systems-to-keep (remove (lambda (fs) (string=? (file-system-mount-point fs) "/")) (operating-system-file-systems os))) (let ((os (operating-system (inherit os) ;; Since this is meant to be used on real hardware, don't ;; install QEMU networking or anything like that. Assume USB ;; mass storage devices (usb-storage.ko) are available. (initrd (lambda (file-systems . rest) (apply base-initrd file-systems #:volatile-root? #t rest))) ;; Force our own root file system. (file-systems (cons (file-system (mount-point "/") (device root-label) (title 'label) (type file-system-type)) file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) (bootcfg (operating-system-bootcfg os))) (if (string=? "iso9660" file-system-type) (iso9660-image #:name name #:file-system-label root-label #:file-system-uuid #f #:os-drv os-drv #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:inputs `(("system" ,os-drv) ("bootcfg" ,bootcfg))) (qemu-image #:name name #:os-drv os-drv #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:disk-image-format "raw" #:file-system-type (if (string=? "iso9660" file-system-type) "ext4" file-system-type) #:file-system-label root-label #:copy-inputs? #t #:register-closures? #t #:inputs `(("system" ,os-drv) ("bootcfg" ,bootcfg))))))) (define* (system-qemu-image os #:key (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." (define file-systems-to-keep ;; Keep only file systems other than root and not normally bound to real ;; devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target "/") (string-prefix? "/dev/" source)))) (operating-system-file-systems os))) (let ((os (operating-system (inherit os) ;; Use an initrd with the whole QEMU shebang. (initrd (lambda (file-systems . rest) (apply base-initrd file-systems #:virtio? #t rest))) ;; Force our own root file system. (file-systems (cons (file-system (mount-point "/") (device "/dev/sda1") (type file-system-type)) file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) (bootcfg (operating-system-bootcfg os))) (qemu-image #:os-drv os-drv #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:file-system-type file-system-type #:inputs `(("system" ,os-drv) ("bootcfg" ,bootcfg)) #:copy-inputs? #t)))) ;;; ;;; VMs that share file systems with the host. ;;; (define (file-system->mount-tag fs) "Return a 9p mount tag for host file system FS." ;; QEMU mount tags cannot contain slashes and cannot start with '_'. ;; Compute an identifier that corresponds to the rules. (string-append "TAG" (string-map (match-lambda (#\/ #\_) (chr chr)) fs))) (define (mapping->file-system mapping) "Return a 9p file system that realizes MAPPING." (match mapping (($ source target writable?) (file-system (mount-point target) (device (file-system->mount-tag source)) (type "9p") (flags (if writable? '() '(read-only))) (options (string-append "trans=virtio")) (check? #f) (create-mount-point? #t))))) (define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of to realize in the virtualized OS." (define user-file-systems ;; Remove file systems that conflict with those added below, or that are ;; normally bound to real devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target (%store-prefix)) (string=? target "/") (and (eq? 'device (file-system-title fs)) (string-prefix? "/dev/" source))))) (operating-system-file-systems os))) (define virtual-file-systems (cons (file-system (mount-point "/") (device "/dev/vda1") (type "ext4")) (append (map mapping->file-system mappings) user-file-systems))) (operating-system (inherit os) (initrd (lambda (file-systems . rest) (apply base-initrd file-systems #:volatile-root? #t #:virtio? #t rest))) ;; Disable swap. (swap-devices '()) ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store ;; since that would lead the bootloader config to look for the kernel and ;; initrd in it. (file-systems (if full-boot? virtual-file-systems (cons (file-system (inherit (mapping->file-system %store-mapping)) (needed-for-boot? #t)) virtual-file-systems))))) (define* (system-qemu-image/shared-store os #:key full-boot? (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store with the host. When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." (mlet* %store-monad ((os-drv (operating-system-derivation os)) (bootcfg (operating-system-bootcfg os))) ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains ;; BOOTCFG and all its dependencies, including the output of OS-DRV. ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os-drv os-drv #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:inputs (if full-boot? `(("bootcfg" ,bootcfg)) '()) ;; XXX: Passing #t here is too slow, so let it off by default. #:register-closures? #f #:copy-inputs? full-boot?))) (define* (common-qemu-options image shared-fs) "Return the a string-value gexp with the common QEMU options to boot IMAGE, with '-virtfs' options for the host file systems listed in SHARED-FS." (define (virtfs-option fs) #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s" #$fs #$(file-system->mount-tag fs))) #~(;; Only enable kvm if we see /dev/kvm exists. ;; This allows users without hardware virtualization to still use these ;; commands. #$@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) "-no-reboot" "-net nic,model=virtio" #$@(map virtfs-option shared-fs) "-vga std" (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" #$image))) (define* (system-qemu-image/shared-store-script os #:key (qemu qemu) (graphic? #t) (memory-size 256) (mappings '()) full-boot? (disk-image-size (* (if full-boot? 500 70) (expt 2 20))) (options '())) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host. The virtual machine runs with MEMORY-SIZE MiB of memory. MAPPINGS is a list of specifying mapping of host file systems into the guest. When FULL-BOOT? is true, the returned script runs everything starting from the bootloader; otherwise it directly starts the operating system kernel. The DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; it is mostly useful when FULL-BOOT? is true." (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) (os-drv (operating-system-derivation os)) (image (system-qemu-image/shared-store os #:full-boot? full-boot? #:disk-image-size disk-image-size))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os os-drv "/dev/vda1"))) (define qemu-exec #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) #$@(if full-boot? #~() #~("-kernel" #$(operating-system-kernel-file os) "-initrd" #$(file-append os-drv "/initrd") (format #f "-append ~s" (string-join #$kernel-arguments " ")))) #$@(common-qemu-options image (map file-system-mapping-source (cons %store-mapping mappings))) "-m " (number->string #$memory-size) #$@options)) (define builder #~(call-with-output-file #$output (lambda (port) (format port "#!~a~% exec ~a \"$@\"~%" #$(file-append bash "/bin/sh") (string-join #$qemu-exec " ")) (chmod port #o555)))) (gexp->derivation "run-vm.sh" builder))) ;;; ;;; High-level abstraction. ;;; (define-record-type* %virtual-machine make-virtual-machine virtual-machine? (operating-system virtual-machine-operating-system) ; (qemu virtual-machine-qemu ; (default qemu)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) (memory-size virtual-machine-memory-size ;integer (MiB) (default 256)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs (default '()))) (define-syntax virtual-machine (syntax-rules () "Declare a virtual machine running the specified OS, with the given options." ((_ os) ;shortcut (%virtual-machine (operating-system os))) ((_ fields ...) (%virtual-machine fields ...)))) (define (port-forwardings->qemu-options forwardings) "Return the QEMU option for the given port FORWARDINGS as a string, where FORWARDINGS is a list of host-port/guest-port pairs." (string-join (map (match-lambda ((host-port . guest-port) (string-append "hostfwd=tcp::" (number->string host-port) "-:" (number->string guest-port)))) forwardings) ",")) (define-gexp-compiler (virtual-machine-compiler (vm ) system target) ;; XXX: SYSTEM and TARGET are ignored. (match vm (($ os qemu graphic? memory-size ()) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size)) (($ os qemu graphic? memory-size forwardings) (let ((options `("-net" ,(string-append "user," (port-forwardings->qemu-options forwardings))))) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size #:options options))))) ;;; vm.scm ends here