tests/system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2018, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-system)
  21   #:use-module (gnu)
  22   #:use-module ((gnu services) #:select (service-value))
  23   #:use-module (guix store)
  24   #:use-module (guix monads)
  25   #:use-module ((guix gexp) #:select (lower-object))
  26   #:use-module ((guix utils) #:select (%current-system))
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-64))
  29
  30 ;; Test the (gnu system) module.
  31
  32 (define %root-fs
  33   (file-system
  34     (device (file-system-label "my-root"))
  35     (mount-point "/")
  36     (type "ext4")))
  37
  38 (define %os
  39   (operating-system
  40     (host-name "komputilo")
  41     (timezone "Europe/Berlin")
  42     (locale "en_US.utf8")
  43     (bootloader (bootloader-configuration
  44                  (bootloader grub-bootloader)
  45                  (targets '("/dev/sdX"))))
  46     (file-systems (cons %root-fs %base-file-systems))
  47
  48     (users %base-user-accounts)))
  49
  50 (define %luks-device
  51   (mapped-device
  52    (source "/dev/foo") (target "my-luks-device")
  53    (type luks-device-mapping)))
  54
  55 (define %os-with-mapped-device
  56   (operating-system
  57     (host-name "komputilo")
  58     (timezone "Europe/Berlin")
  59     (locale "en_US.utf8")
  60     (bootloader (bootloader-configuration
  61                  (bootloader grub-bootloader)
  62                  (targets '("/dev/sdX"))))
  63     (mapped-devices (list %luks-device))
  64     (file-systems (cons (file-system
  65                           (inherit %root-fs)
  66                           (dependencies (list %luks-device)))
  67                         %base-file-systems))
  68     (users %base-user-accounts)))
  69
  70 (%graft? #f)
  71
  72 \f
  73 (test-begin "system")
  74
  75 (test-assert "operating-system-store-file-system"
  76   ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
  77   ;; shouldn't be a problem.
  78   (eq? %root-fs
  79        (operating-system-store-file-system %os)))
  80
  81 (test-assert "operating-system-store-file-system, prefix"
  82   (let* ((gnu (file-system
  83                 (device "foobar")
  84                 (mount-point (dirname (%store-prefix)))
  85                 (type "ext5")))
  86          (os  (operating-system
  87                 (inherit %os)
  88                 (file-systems (cons* gnu %root-fs
  89                                      %base-file-systems)))))
  90     (eq? gnu (operating-system-store-file-system os))))
  91
  92 (test-assert "operating-system-store-file-system, store"
  93   (let* ((gnu (file-system
  94                 (device "foobar")
  95                 (mount-point (%store-prefix))
  96                 (type "ext5")))
  97          (os  (operating-system
  98                 (inherit %os)
  99                 (file-systems (cons* gnu %root-fs
 100                                      %base-file-systems)))))
 101     (eq? gnu (operating-system-store-file-system os))))
 102
 103 (test-equal "operating-system-user-mapped-devices"
 104   '()
 105   (operating-system-user-mapped-devices %os-with-mapped-device))
 106
 107 (test-equal "operating-system-boot-mapped-devices"
 108   (list %luks-device)
 109   (operating-system-boot-mapped-devices %os-with-mapped-device))
 110
 111 (test-equal "operating-system-boot-mapped-devices, implicit dependency"
 112   (list %luks-device)
 113
 114   ;; Here we expect the implicit dependency between "/" and
 115   ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
 116   ;; 'dependencies' field in the root file system.
 117   (operating-system-boot-mapped-devices
 118    (operating-system
 119      (inherit %os-with-mapped-device)
 120      (file-systems (cons (file-system
 121                            (device "/dev/mapper/my-luks-device")
 122                            (mount-point "/")
 123                            (type "ext4"))
 124                          %base-file-systems)))))
 125
 126 (test-equal "non-boot-file-system-service"
 127   '()
 128
 129   ;; Make sure that mapped devices with at least one needed-for-boot user are
 130   ;; handled exclusively from the initrd.  See <https://bugs.gnu.org/31889>.
 131   (append-map file-system-dependencies
 132               (service-value
 133                ((@@ (gnu system) non-boot-file-system-service)
 134                 (operating-system
 135                   (inherit %os-with-mapped-device)
 136                   (file-systems
 137                    (list (file-system
 138                            (mount-point "/foo/bar")
 139                            (device "qux:baz")
 140                            (type "none")
 141                            (dependencies (list %luks-device)))
 142                          (file-system
 143                            (device (file-system-label "my-root"))
 144                            (mount-point "/")
 145                            (type "ext4")
 146                            (dependencies (list %luks-device))))))))))
 147
 148 (test-assert "lower-object, %current-system sensitivity"
 149   ;; Make sure that 'lower-object' returns the same derivation, no matter what
 150   ;; '%current-system' is.  See <https://issues.guix.gnu.org/55951>.
 151   (let ((drv1 (with-store store
 152                 (parameterize ((%current-system "x86_64-linux"))
 153                   (run-with-store store
 154                     (lower-object %os "aarch64-linux")))))
 155         (drv2 (with-store store
 156                 (parameterize ((%current-system "aarch64-linux"))
 157                   (run-with-store store
 158                     (lower-object %os "aarch64-linux"))))))
 159     (eq? drv1 drv2)))
 160
 161 (test-end)