tests/system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-system)
  20   #:use-module (gnu)
  21   #:use-module (guix store)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-64))
  24
  25 ;; Test the (gnu system) module.
  26
  27 (define %root-fs
  28   (file-system
  29     (device "my-root")
  30     (title 'label)
  31     (mount-point "/")
  32     (type "ext4")))
  33
  34 (define %os
  35   (operating-system
  36     (host-name "komputilo")
  37     (timezone "Europe/Berlin")
  38     (locale "en_US.utf8")
  39     (bootloader (grub-configuration (target "/dev/sdX")))
  40     (file-systems (cons %root-fs %base-file-systems))
  41
  42     (users %base-user-accounts)))
  43
  44 (define %luks-device
  45   (mapped-device
  46    (source "/dev/foo") (target "my-luks-device")
  47    (type luks-device-mapping)))
  48
  49 (define %os-with-mapped-device
  50   (operating-system
  51     (host-name "komputilo")
  52     (timezone "Europe/Berlin")
  53     (locale "en_US.utf8")
  54     (bootloader (grub-configuration (target "/dev/sdX")))
  55     (mapped-devices (list %luks-device))
  56     (file-systems (cons (file-system
  57                           (inherit %root-fs)
  58                           (dependencies (list %luks-device)))
  59                         %base-file-systems))
  60     (users %base-user-accounts)))
  61
  62 \f
  63 (test-begin "system")
  64
  65 (test-assert "operating-system-store-file-system"
  66   ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
  67   ;; shouldn't be a problem.
  68   (eq? %root-fs
  69        (operating-system-store-file-system %os)))
  70
  71 (test-assert "operating-system-store-file-system, prefix"
  72   (let* ((gnu (file-system
  73                 (device "foobar")
  74                 (mount-point (dirname (%store-prefix)))
  75                 (type "ext5")))
  76          (os  (operating-system
  77                 (inherit %os)
  78                 (file-systems (cons* gnu %root-fs
  79                                      %base-file-systems)))))
  80     (eq? gnu (operating-system-store-file-system os))))
  81
  82 (test-assert "operating-system-store-file-system, store"
  83   (let* ((gnu (file-system
  84                 (device "foobar")
  85                 (mount-point (%store-prefix))
  86                 (type "ext5")))
  87          (os  (operating-system
  88                 (inherit %os)
  89                 (file-systems (cons* gnu %root-fs
  90                                      %base-file-systems)))))
  91     (eq? gnu (operating-system-store-file-system os))))
  92
  93 (test-equal "operating-system-user-mapped-devices"
  94   '()
  95   (operating-system-user-mapped-devices %os-with-mapped-device))
  96
  97 (test-equal "operating-system-boot-mapped-devices"
  98   (list %luks-device)
  99   (operating-system-boot-mapped-devices %os-with-mapped-device))
 100
 101 (test-equal "operating-system-boot-mapped-devices, implicit dependency"
 102   (list %luks-device)
 103
 104   ;; Here we expect the implicit dependency between "/" and
 105   ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
 106   ;; 'dependencies' field in the root file system.
 107   (operating-system-boot-mapped-devices
 108    (operating-system
 109      (inherit %os-with-mapped-device)
 110      (file-systems (cons (file-system
 111                            (device "/dev/mapper/my-luks-device")
 112                            (title 'device)
 113                            (mount-point "/")
 114                            (type "ext4"))
 115                          %base-file-systems)))))
 116
 117 (test-end)