summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-09-03 14:19:51 +0200
committerLudovic Courtès <ludo@gnu.org>2014-09-03 15:43:07 +0200
commite2f4b305d0b7cff1e19c7f67ea633ef8a971e712 (patch)
tree65302d216abc0b0811e4beb41179f586abe01a41
parent8a9e21d1f719748213414343cd02ec113ebe90c1 (diff)
Move part of (gnu build linux-boot) to (gnu build file-systems).
* gnu/build/linux-boot.scm (%ext2-endianness, %ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name, read-ext2-superblock, ext2-superblock-uuid, ext2-superblock-volume-name, disk-partitions, partition-label-predicate, find-partition-by-label, canonicalize-device-spec, MS_RDONLY, MS_NOSUID, MS_NODEV, MS_NOEXEC, MS_BIND, MS_MOVE, bind-mount, check-file-system, mount-flags->bit-mask, mount-file-system): Move to... * gnu/build/file-systems.scm: ... here. New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * gnu/services/base.scm: Use (gnu build file-systems). * gnu/services/dmd.scm (dmd-configuration-file): Likewise. * gnu/system.scm (operating-system-activation-script): Likewise. * gnu/system/linux-initrd.scm (base-initrd): Likewise. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise.
-rw-r--r--gnu-system.am1
-rw-r--r--gnu/build/file-systems.scm299
-rw-r--r--gnu/build/linux-boot.scm259
-rw-r--r--gnu/services/base.scm2
-rw-r--r--gnu/services/dmd.scm4
-rw-r--r--gnu/system.scm1
-rw-r--r--gnu/system/linux-initrd.scm3
-rw-r--r--gnu/system/vm.scm1
8 files changed, 308 insertions, 262 deletions
diff --git a/gnu-system.am b/gnu-system.am
index 8e7de7c622c..d4f27314c20 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -280,6 +280,7 @@ GNU_SYSTEM_MODULES = \
280 gnu/system/vm.scm \ 280 gnu/system/vm.scm \
281 \ 281 \
282 gnu/build/activation.scm \ 282 gnu/build/activation.scm \
283 gnu/build/file-systems.scm \
283 gnu/build/install.scm \ 284 gnu/build/install.scm \
284 gnu/build/linux-boot.scm \ 285 gnu/build/linux-boot.scm \
285 gnu/build/vm.scm 286 gnu/build/vm.scm
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
new file mode 100644
index 00000000000..5c04771e192
--- /dev/null
+++ b/gnu/build/file-systems.scm
@@ -0,0 +1,299 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014 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 (gnu build file-systems)
20 #:use-module (guix build utils)
21 #:use-module (rnrs io ports)
22 #:use-module (rnrs bytevectors)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 rdelim)
25 #:use-module (system foreign)
26 #:autoload (system repl repl) (start-repl)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-26)
29 #:export (disk-partitions
30 partition-label-predicate
31 find-partition-by-label
32 canonicalize-device-spec
33
34 MS_RDONLY
35 MS_NOSUID
36 MS_NODEV
37 MS_NOEXEC
38 MS_BIND
39 MS_MOVE
40 bind-mount
41
42 mount-flags->bit-mask
43 check-file-system
44 mount-file-system))
45
46;;; Commentary:
47;;;
48;;; This modules provides tools to deal with disk partitions, and to mount and
49;;; check file systems.
50;;;
51;;; Code:
52
53;; Linux mount flags, from libc's <sys/mount.h>.
54(define MS_RDONLY 1)
55(define MS_NOSUID 2)
56(define MS_NODEV 4)
57(define MS_NOEXEC 8)
58(define MS_BIND 4096)
59(define MS_MOVE 8192)
60
61(define (bind-mount source target)
62 "Bind-mount SOURCE at TARGET."
63 (mount source target "" MS_BIND))
64
65(define-syntax %ext2-endianness
66 ;; Endianness of ext2 file systems.
67 (identifier-syntax (endianness little)))
68
69;; Offset in bytes of interesting parts of an ext2 superblock. See
70;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
71;; TODO: Use "packed structs" from Guile-OpenGL or similar.
72(define-syntax %ext2-sblock-magic (identifier-syntax 56))
73(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
74(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
75(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
76
77(define (read-ext2-superblock device)
78 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
79if DEVICE does not contain an ext2 file system."
80 (define %ext2-magic
81 ;; The magic bytes that identify an ext2 file system.
82 #xef53)
83
84 (define superblock-size
85 ;; Size of the interesting part of an ext2 superblock.
86 264)
87
88 (define block
89 ;; The superblock contents.
90 (make-bytevector superblock-size))
91
92 (call-with-input-file device
93 (lambda (port)
94 (seek port 1024 SEEK_SET)
95
96 ;; Note: work around <http://bugs.gnu.org/17466>.
97 (and (eqv? superblock-size (get-bytevector-n! port block 0
98 superblock-size))
99 (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
100 %ext2-endianness)))
101 (and (= magic %ext2-magic)
102 block))))))
103
104(define (ext2-superblock-uuid sblock)
105 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
106 (let ((uuid (make-bytevector 16)))
107 (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
108 uuid))
109
110(define (ext2-superblock-volume-name sblock)
111 "Return the volume name of SBLOCK as a string of at most 16 characters, or
112#f if SBLOCK has no volume name."
113 (let ((bv (make-bytevector 16)))
114 (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
115
116 ;; This is a Latin-1, nul-terminated string.
117 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
118 (if (null? bytes)
119 #f
120 (list->string (map integer->char bytes))))))
121
122(define (disk-partitions)
123 "Return the list of device names corresponding to valid disk partitions."
124 (define (partition? major minor)
125 (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
126 (catch 'system-error
127 (lambda ()
128 (not (zero? (call-with-input-file marker read))))
129 (lambda args
130 (if (= ENOENT (system-error-errno args))
131 #f
132 (apply throw args))))))
133
134 (call-with-input-file "/proc/partitions"
135 (lambda (port)
136 ;; Skip the two header lines.
137 (read-line port)
138 (read-line port)
139
140 ;; Read each subsequent line, and extract the last space-separated
141 ;; field.
142 (let loop ((parts '()))
143 (let ((line (read-line port)))
144 (if (eof-object? line)
145 (reverse parts)
146 (match (string-tokenize line)
147 (((= string->number major) (= string->number minor)
148 blocks name)
149 (if (partition? major minor)
150 (loop (cons name parts))
151 (loop parts))))))))))
152
153(define (partition-label-predicate label)
154 "Return a procedure that, when applied to a partition name such as \"sda1\",
155return #t if that partition's volume name is LABEL."
156 (lambda (part)
157 (let* ((device (string-append "/dev/" part))
158 (sblock (catch 'system-error
159 (lambda ()
160 (read-ext2-superblock device))
161 (lambda args
162 ;; When running on the hand-made /dev,
163 ;; 'disk-partitions' could return partitions for which
164 ;; we have no /dev node. Handle that gracefully.
165 (if (= ENOENT (system-error-errno args))
166 (begin
167 (format (current-error-port)
168 "warning: device '~a' not found~%"
169 device)
170 #f)
171 (apply throw args))))))
172 (and sblock
173 (let ((volume (ext2-superblock-volume-name sblock)))
174 (and volume
175 (string=? volume label)))))))
176
177(define (find-partition-by-label label)
178 "Return the first partition found whose volume name is LABEL, or #f if none
179were found."
180 (and=> (find (partition-label-predicate label)
181 (disk-partitions))
182 (cut string-append "/dev/" <>)))
183
184(define* (canonicalize-device-spec spec #:optional (title 'any))
185 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
186the following:
187
188 • 'device', in which case SPEC is known to designate a device node--e.g.,
189 \"/dev/sda1\";
190 • 'label', in which case SPEC is known to designate a partition label--e.g.,
191 \"my-root-part\";
192 • 'any', in which case SPEC can be anything.
193"
194 (define max-trials
195 ;; Number of times we retry partition label resolution, 1 second per
196 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
197 ;; USB key would be detected by the kernel, so we must wait for at least
198 ;; this long.
199 20)
200
201 (define canonical-title
202 ;; The realm of canonicalization.
203 (if (eq? title 'any)
204 (if (string-prefix? "/" spec)
205 'device
206 'label)
207 title))
208
209 (case canonical-title
210 ((device)
211 ;; Nothing to do.
212 spec)
213 ((label)
214 ;; Resolve the label.
215 (let loop ((count 0))
216 (let ((device (find-partition-by-label spec)))
217 (or device
218 ;; Some devices take a bit of time to appear, most notably USB
219 ;; storage devices. Thus, wait for the device to appear.
220 (if (> count max-trials)
221 (error "failed to resolve partition label" spec)
222 (begin
223 (format #t "waiting for partition '~a' to appear...~%"
224 spec)
225 (sleep 1)
226 (loop (+ 1 count))))))))
227 ;; TODO: Add support for UUIDs.
228 (else
229 (error "unknown device title" title))))
230
231(define (check-file-system device type)
232 "Run a file system check of TYPE on DEVICE."
233 (define fsck
234 (string-append "fsck." type))
235
236 (let ((status (system* fsck "-v" "-p" device)))
237 (match (status:exit-val status)
238 (0
239 #t)
240 (1
241 (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
242 fsck device))
243 (2
244 (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
245 fsck device)
246 (sleep 3)
247 (reboot))
248 (code
249 (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
250 fsck code device)
251 (start-repl)))))
252
253(define (mount-flags->bit-mask flags)
254 "Return the number suitable for the 'flags' argument of 'mount' that
255corresponds to the symbols listed in FLAGS."
256 (let loop ((flags flags))
257 (match flags
258 (('read-only rest ...)
259 (logior MS_RDONLY (loop rest)))
260 (('bind-mount rest ...)
261 (logior MS_BIND (loop rest)))
262 (('no-suid rest ...)
263 (logior MS_NOSUID (loop rest)))
264 (('no-dev rest ...)
265 (logior MS_NODEV (loop rest)))
266 (('no-exec rest ...)
267 (logior MS_NOEXEC (loop rest)))
268 (()
269 0))))
270
271(define* (mount-file-system spec #:key (root "/root"))
272 "Mount the file system described by SPEC under ROOT. SPEC must have the
273form:
274
275 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
276
277DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
278FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
279run a file system check."
280 (match spec
281 ((source title mount-point type (flags ...) options check?)
282 (let ((source (canonicalize-device-spec source title))
283 (mount-point (string-append root "/" mount-point)))
284 (when check?
285 (check-file-system source type))
286 (mkdir-p mount-point)
287 (mount source mount-point type (mount-flags->bit-mask flags)
288 (if options
289 (string->pointer options)
290 %null-pointer))
291
292 ;; Update /etc/mtab.
293 (mkdir-p (string-append root "/etc"))
294 (let ((port (open-file (string-append root "/etc/mtab") "a")))
295 (format port "~a ~a ~a ~a 0 0~%"
296 source mount-point type (or options ""))
297 (close-port port))))))
298
299;;; file-systems.scm ends here
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 24000e191a7..21ee58ad506 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -18,33 +18,22 @@
18 18
19(define-module (gnu build linux-boot) 19(define-module (gnu build linux-boot)
20 #:use-module (rnrs io ports) 20 #:use-module (rnrs io ports)
21 #:use-module (rnrs bytevectors)
22 #:use-module (system foreign)
23 #:use-module (system repl error-handling) 21 #:use-module (system repl error-handling)
24 #:autoload (system repl repl) (start-repl) 22 #:autoload (system repl repl) (start-repl)
25 #:autoload (system base compile) (compile-file) 23 #:autoload (system base compile) (compile-file)
26 #:use-module (srfi srfi-1) 24 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-26) 25 #:use-module (srfi srfi-26)
28 #:use-module (ice-9 match) 26 #:use-module (ice-9 match)
29 #:use-module (ice-9 rdelim)
30 #:use-module (ice-9 ftw) 27 #:use-module (ice-9 ftw)
31 #:use-module (guix build utils) 28 #:use-module (guix build utils)
29 #:use-module (gnu build file-systems)
32 #:export (mount-essential-file-systems 30 #:export (mount-essential-file-systems
33 linux-command-line 31 linux-command-line
34 find-long-option 32 find-long-option
35 make-essential-device-nodes 33 make-essential-device-nodes
36 configure-qemu-networking 34 configure-qemu-networking
37 35
38 disk-partitions
39 partition-label-predicate
40 find-partition-by-label
41 canonicalize-device-spec
42
43 mount-flags->bit-mask
44 check-file-system
45 mount-file-system
46 bind-mount 36 bind-mount
47
48 load-linux-module* 37 load-linux-module*
49 device-number 38 device-number
50 boot-system)) 39 boot-system))
@@ -99,172 +88,6 @@ Return the value associated with OPTION, or #f on failure."
99 (lambda (arg) 88 (lambda (arg)
100 (substring arg (+ 1 (string-index arg #\=))))))) 89 (substring arg (+ 1 (string-index arg #\=)))))))
101 90
102(define-syntax %ext2-endianness
103 ;; Endianness of ext2 file systems.
104 (identifier-syntax (endianness little)))
105
106;; Offset in bytes of interesting parts of an ext2 superblock. See
107;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
108;; TODO: Use "packed structs" from Guile-OpenGL or similar.
109(define-syntax %ext2-sblock-magic (identifier-syntax 56))
110(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
111(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
112(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
113
114(define (read-ext2-superblock device)
115 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
116if DEVICE does not contain an ext2 file system."
117 (define %ext2-magic
118 ;; The magic bytes that identify an ext2 file system.
119 #xef53)
120
121 (define superblock-size
122 ;; Size of the interesting part of an ext2 superblock.
123 264)
124
125 (define block
126 ;; The superblock contents.
127 (make-bytevector superblock-size))
128
129 (call-with-input-file device
130 (lambda (port)
131 (seek port 1024 SEEK_SET)
132
133 ;; Note: work around <http://bugs.gnu.org/17466>.
134 (and (eqv? superblock-size (get-bytevector-n! port block 0
135 superblock-size))
136 (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
137 %ext2-endianness)))
138 (and (= magic %ext2-magic)
139 block))))))
140
141(define (ext2-superblock-uuid sblock)
142 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
143 (let ((uuid (make-bytevector 16)))
144 (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
145 uuid))
146
147(define (ext2-superblock-volume-name sblock)
148 "Return the volume name of SBLOCK as a string of at most 16 characters, or
149#f if SBLOCK has no volume name."
150 (let ((bv (make-bytevector 16)))
151 (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
152
153 ;; This is a Latin-1, nul-terminated string.
154 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
155 (if (null? bytes)
156 #f
157 (list->string (map integer->char bytes))))))
158
159(define (disk-partitions)
160 "Return the list of device names corresponding to valid disk partitions."
161 (define (partition? major minor)
162 (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
163 (catch 'system-error
164 (lambda ()
165 (not (zero? (call-with-input-file marker read))))
166 (lambda args
167 (if (= ENOENT (system-error-errno args))
168 #f
169 (apply throw args))))))
170
171 (call-with-input-file "/proc/partitions"
172 (lambda (port)
173 ;; Skip the two header lines.
174 (read-line port)
175 (read-line port)
176
177 ;; Read each subsequent line, and extract the last space-separated
178 ;; field.
179 (let loop ((parts '()))
180 (let ((line (read-line port)))
181 (if (eof-object? line)
182 (reverse parts)
183 (match (string-tokenize line)
184 (((= string->number major) (= string->number minor)
185 blocks name)
186 (if (partition? major minor)
187 (loop (cons name parts))
188 (loop parts))))))))))
189
190(define (partition-label-predicate label)
191 "Return a procedure that, when applied to a partition name such as \"sda1\",
192return #t if that partition's volume name is LABEL."
193 (lambda (part)
194 (let* ((device (string-append "/dev/" part))
195 (sblock (catch 'system-error
196 (lambda ()
197 (read-ext2-superblock device))
198 (lambda args
199 ;; When running on the hand-made /dev,
200 ;; 'disk-partitions' could return partitions for which
201 ;; we have no /dev node. Handle that gracefully.
202 (if (= ENOENT (system-error-errno args))
203 (begin
204 (format (current-error-port)
205 "warning: device '~a' not found~%"
206 device)
207 #f)
208 (apply throw args))))))
209 (and sblock
210 (let ((volume (ext2-superblock-volume-name sblock)))
211 (and volume
212 (string=? volume label)))))))
213
214(define (find-partition-by-label label)
215 "Return the first partition found whose volume name is LABEL, or #f if none
216were found."
217 (and=> (find (partition-label-predicate label)
218 (disk-partitions))
219 (cut string-append "/dev/" <>)))
220
221(define* (canonicalize-device-spec spec #:optional (title 'any))
222 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
223the following:
224
225 • 'device', in which case SPEC is known to designate a device node--e.g.,
226 \"/dev/sda1\";
227 • 'label', in which case SPEC is known to designate a partition label--e.g.,
228 \"my-root-part\";
229 • 'any', in which case SPEC can be anything.
230"
231 (define max-trials
232 ;; Number of times we retry partition label resolution, 1 second per
233 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
234 ;; USB key would be detected by the kernel, so we must wait for at least
235 ;; this long.
236 20)
237
238 (define canonical-title
239 ;; The realm of canonicalization.
240 (if (eq? title 'any)
241 (if (string-prefix? "/" spec)
242 'device
243 'label)
244 title))
245
246 (case canonical-title
247 ((device)
248 ;; Nothing to do.
249 spec)
250 ((label)
251 ;; Resolve the label.
252 (let loop ((count 0))
253 (let ((device (find-partition-by-label spec)))
254 (or device
255 ;; Some devices take a bit of time to appear, most notably USB
256 ;; storage devices. Thus, wait for the device to appear.
257 (if (> count max-trials)
258 (error "failed to resolve partition label" spec)
259 (begin
260 (format #t "waiting for partition '~a' to appear...~%"
261 spec)
262 (sleep 1)
263 (loop (+ 1 count))))))))
264 ;; TODO: Add support for UUIDs.
265 (else
266 (error "unknown device title" title))))
267
268(define* (make-disk-device-nodes base major #:optional (minor 0)) 91(define* (make-disk-device-nodes base major #:optional (minor 0))
269 "Make the block device nodes around BASE (something like \"/root/dev/sda\") 92 "Make the block device nodes around BASE (something like \"/root/dev/sda\")
270with the given MAJOR number, starting with MINOR." 93with the given MAJOR number, starting with MINOR."
@@ -395,18 +218,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise."
395 218
396 (logand (network-interface-flags sock interface) IFF_UP))) 219 (logand (network-interface-flags sock interface) IFF_UP)))
397 220
398;; Linux mount flags, from libc's <sys/mount.h>.
399(define MS_RDONLY 1)
400(define MS_NOSUID 2)
401(define MS_NODEV 4)
402(define MS_NOEXEC 8)
403(define MS_BIND 4096)
404(define MS_MOVE 8192)
405
406(define (bind-mount source target)
407 "Bind-mount SOURCE at TARGET."
408 (mount source target "" MS_BIND))
409
410(define (load-linux-module* file) 221(define (load-linux-module* file)
411 "Load Linux module from FILE, the name of a `.ko' file." 222 "Load Linux module from FILE, the name of a `.ko' file."
412 (define (slurp module) 223 (define (slurp module)
@@ -479,74 +290,6 @@ UNIONFS."
479 290
480 (copy-file "/proc/mounts" "/root/etc/mtab")) 291 (copy-file "/proc/mounts" "/root/etc/mtab"))
481 292
482(define (check-file-system device type)
483 "Run a file system check of TYPE on DEVICE."
484 (define fsck
485 (string-append "fsck." type))
486
487 (let ((status (system* fsck "-v" "-p" device)))
488 (match (status:exit-val status)
489 (0
490 #t)
491 (1
492 (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
493 fsck device))
494 (2
495 (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
496 fsck device)
497 (sleep 3)
498 (reboot))
499 (code
500 (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
501 fsck code device)
502 (start-repl)))))
503
504(define (mount-flags->bit-mask flags)
505 "Return the number suitable for the 'flags' argument of 'mount' that
506corresponds to the symbols listed in FLAGS."
507 (let loop ((flags flags))
508 (match flags
509 (('read-only rest ...)
510 (logior MS_RDONLY (loop rest)))
511 (('bind-mount rest ...)
512 (logior MS_BIND (loop rest)))
513 (('no-suid rest ...)
514 (logior MS_NOSUID (loop rest)))
515 (('no-dev rest ...)
516 (logior MS_NODEV (loop rest)))
517 (('no-exec rest ...)
518 (logior MS_NOEXEC (loop rest)))
519 (()
520 0))))
521
522(define* (mount-file-system spec #:key (root "/root"))
523 "Mount the file system described by SPEC under ROOT. SPEC must have the
524form:
525
526 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
527
528DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
529FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
530run a file system check."
531 (match spec
532 ((source title mount-point type (flags ...) options check?)
533 (let ((source (canonicalize-device-spec source title))
534 (mount-point (string-append root "/" mount-point)))
535 (when check?
536 (check-file-system source type))
537 (mkdir-p mount-point)
538 (mount source mount-point type (mount-flags->bit-mask flags)
539 (if options
540 (string->pointer options)
541 %null-pointer))
542
543 ;; Update /etc/mtab.
544 (mkdir-p (string-append root "/etc"))
545 (let ((port (open-file (string-append root "/etc/mtab") "a")))
546 (format port "~a ~a ~a ~a 0 0~%"
547 source mount-point type (or options ""))
548 (close-port port))))))
549
550(define (switch-root root) 293(define (switch-root root)
551 "Switch to ROOT as the root file system, in a way similar to what 294 "Switch to ROOT as the root file system, in a way similar to what
552util-linux' switch_root(8) does." 295util-linux' switch_root(8) does."
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index e9adb47ac02..b5b49d1a01b 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -29,7 +29,7 @@
29 #:use-module ((gnu packages base) 29 #:use-module ((gnu packages base)
30 #:select (canonical-package glibc)) 30 #:select (canonical-package glibc))
31 #:use-module (gnu packages package-management) 31 #:use-module (gnu packages package-management)
32 #:use-module ((gnu build linux-boot) 32 #:use-module ((gnu build file-systems)
33 #:select (mount-flags->bit-mask)) 33 #:select (mount-flags->bit-mask))
34 #:use-module (guix gexp) 34 #:use-module (guix gexp)
35 #:use-module (guix monads) 35 #:use-module (guix monads)
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index d1fa58f9d78..59c23737798 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -35,7 +35,7 @@
35 (define modules 35 (define modules
36 ;; Extra modules visible to dmd.conf. 36 ;; Extra modules visible to dmd.conf.
37 '((guix build syscalls) 37 '((guix build syscalls)
38 (gnu build linux-boot) 38 (gnu build file-systems)
39 (guix build utils))) 39 (guix build utils)))
40 40
41 (mlet %store-monad ((modules (imported-modules modules)) 41 (mlet %store-monad ((modules (imported-modules modules))
@@ -50,7 +50,7 @@
50 (use-modules (ice-9 ftw) 50 (use-modules (ice-9 ftw)
51 (guix build syscalls) 51 (guix build syscalls)
52 (guix build utils) 52 (guix build utils)
53 ((gnu build linux-boot) 53 ((gnu build file-systems)
54 #:select (check-file-system canonicalize-device-spec))) 54 #:select (check-file-system canonicalize-device-spec)))
55 55
56 (register-services 56 (register-services
diff --git a/gnu/system.scm b/gnu/system.scm
index e011a00f163..ea7fdf1cb78 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -364,6 +364,7 @@ etc."
364 (define %modules 364 (define %modules
365 '((gnu build activation) 365 '((gnu build activation)
366 (gnu build linux-boot) 366 (gnu build linux-boot)
367 (gnu build file-systems)
367 (guix build utils))) 368 (guix build utils)))
368 369
369 (define (service-activations services) 370 (define (service-activations services)
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 93c739c99e0..c4ab73ec9a2 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -293,7 +293,8 @@ exception and backtrace!)."
293 #:volatile-root? '#$volatile-root?)) 293 #:volatile-root? '#$volatile-root?))
294 #:name "base-initrd" 294 #:name "base-initrd"
295 #:modules '((guix build utils) 295 #:modules '((guix build utils)
296 (gnu build linux-boot)) 296 (gnu build linux-boot)
297 (gnu build file-systems))
297 #:to-copy helper-packages 298 #:to-copy helper-packages
298 #:linux linux-libre 299 #:linux linux-libre
299 #:linux-modules linux-modules)) 300 #:linux-modules linux-modules))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3e26dfb700f..d263edb4f1a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -115,6 +115,7 @@ input tuple. The output file name is when building for SYSTEM."
115 '((gnu build vm) 115 '((gnu build vm)
116 (gnu build install) 116 (gnu build install)
117 (gnu build linux-boot) 117 (gnu build linux-boot)
118 (gnu build file-systems)
118 (guix build utils))) 119 (guix build utils)))
119 (guile-for-build 120 (guile-for-build
120 (%guile-for-build)) 121 (%guile-for-build))