projects/guix·blob python-team · refs

133 lines · 4.7 KiB

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