tests/file-systems.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   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-file-systems)
  21   #:use-module (guix store)
  22   #:use-module (guix modules)
  23   #:use-module (gnu system file-systems)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-64)
  26   #:use-module (ice-9 match))
  27
  28 ;; Test the (gnu system file-systems) module.
  29
  30 (test-begin "file-systems")
  31
  32 (test-assert "file-system-needed-for-boot?"
  33   (let-syntax ((dummy-fs (syntax-rules ()
  34                            ((_ directory)
  35                             (file-system
  36                               (device "foo")
  37                               (mount-point directory)
  38                               (type "ext4"))))))
  39     (parameterize ((%store-prefix "/gnu/guix/store"))
  40       (and (file-system-needed-for-boot? (dummy-fs "/"))
  41            (file-system-needed-for-boot? (dummy-fs "/gnu"))
  42            (file-system-needed-for-boot? (dummy-fs "/gnu/guix"))
  43            (file-system-needed-for-boot? (dummy-fs "/gnu/guix/store"))
  44            (not (file-system-needed-for-boot?
  45                  (dummy-fs "/gnu/guix/store/foo")))
  46            (not (file-system-needed-for-boot? (dummy-fs "/gn")))
  47            (not (file-system-needed-for-boot?
  48                  (file-system
  49                    (inherit (dummy-fs (%store-prefix)))
  50                    (device "/foo")
  51                    (flags '(bind-mount read-only)))))))))
  52
  53 (test-assert "does not pull (guix config)"
  54   ;; This module is meant both for the host side and "build side", so make
  55   ;; sure it doesn't pull in (guix config), which depends on the user's
  56   ;; config.
  57   (not (member '(guix config)
  58                (source-module-closure '((gnu system file-systems))))))
  59
  60 (test-equal "does not pull (gnu packages …)"
  61   ;; Same story: (gnu packages …) should not be pulled.
  62   #f
  63   (find (match-lambda
  64           (('gnu 'packages _ ..1) #t)
  65           (_ #f))
  66         (source-module-closure '((gnu system file-systems)))))
  67
  68 (test-equal "file-system-options->alist"
  69   '("autodefrag" ("subvol" . "home") ("compress" . "lzo"))
  70   (file-system-options->alist "autodefrag,subvol=home,compress=lzo"))
  71
  72 (test-equal "file-system-options->alist (#f)"
  73   '()
  74   (file-system-options->alist #f))
  75
  76 (test-equal "alist->file-system-options"
  77   "autodefrag,subvol=root,compress=lzo"
  78   (alist->file-system-options '("autodefrag"
  79                                 ("subvol" . "root")
  80                                 ("compress" . "lzo"))))
  81
  82 (test-equal "alist->file-system-options (null)"
  83   #f
  84   (alist->file-system-options '()))
  85
  86 \f
  87 ;;;
  88 ;;; Btrfs related.
  89 ;;;
  90
  91 (define %btrfs-root-subvolume
  92   (file-system
  93     (device (file-system-label "btrfs-pool"))
  94     (mount-point "/")
  95     (type "btrfs")
  96     (options "subvol=rootfs,compress=zstd")))
  97
  98 (define %btrfs-store-subvolid
  99   (file-system
 100     (device (file-system-label "btrfs-pool"))
 101     (mount-point "/gnu/store")
 102     (type "btrfs")
 103     (options "subvolid=10,compress=zstd")
 104     (dependencies (list %btrfs-root-subvolume))))
 105
 106 (define %btrfs-store-subvolume
 107   (file-system
 108     (device (file-system-label "btrfs-pool"))
 109     (mount-point "/gnu/store")
 110     (type "btrfs")
 111     (options "subvol=/some/nested/file/name")
 112     (dependencies (list %btrfs-root-subvolume))))
 113
 114 (test-assert "btrfs-subvolume? (subvol)"
 115   (btrfs-subvolume? %btrfs-root-subvolume))
 116
 117 (test-assert "btrfs-subvolume? (subvolid)"
 118   (btrfs-subvolume? %btrfs-store-subvolid))
 119
 120 (test-equal "btrfs-store-subvolume-file-name"
 121   "/some/nested/file/name"
 122   (parameterize ((%store-prefix "/gnu/store"))
 123     (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
 124                                            %btrfs-store-subvolume))))
 125
 126 (test-error "btrfs-store-subvolume-file-name (subvolid)"
 127             (parameterize ((%store-prefix "/gnu/store"))
 128               (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
 129                                                      %btrfs-store-subvolid))))
 130
 131 (test-end)