1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 David Craven <david@craven.ch>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
20 (define-module (gnu build file-systems)
21 #:use-module (guix build utils)
22 #:use-module (guix build bournish)
23 #:use-module (guix build syscalls)
24 #:use-module (rnrs io ports)
25 #:use-module (rnrs bytevectors)
26 #:use-module (ice-9 match)
27 #:use-module (ice-9 rdelim)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 regex)
30 #:use-module (system foreign)
31 #:autoload (system repl repl) (start-repl)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-26)
34 #:export (disk-partitions
35 partition-label-predicate
36 partition-uuid-predicate
37 partition-luks-uuid-predicate
38 find-partition-by-label
39 find-partition-by-uuid
40 find-partition-by-luks-uuid
41 canonicalize-device-spec
59 ;;; This modules provides tools to deal with disk partitions, and to mount and
60 ;;; check file systems.
64 ;; 'mount' is already defined in the statically linked Guile used for initial
65 ;; RAM disks, in which case the bindings in (guix build syscalls) do not work
66 ;; (the FFI bindings do not work there). Override them in that case.
67 (when (module-defined? the-scm-module 'mount)
68 (set! mount (@ (guile) mount))
69 (set! umount (@ (guile) umount)))
71 (define (bind-mount source target)
72 "Bind-mount SOURCE at TARGET."
73 (mount source target "" MS_BIND))
75 (define (read-superblock device offset size magic?)
76 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
77 superblock on success, and #f if no valid superblock was found. MAGIC?
78 takes a bytevector and returns #t when it's a valid superblock."
79 (call-with-input-file device
81 (seek port offset SEEK_SET)
83 (let ((block (make-bytevector size)))
84 (match (get-bytevector-n! port block 0 (bytevector-length block))
88 (and (= len (bytevector-length block))
92 (define (sub-bytevector bv start size)
93 "Return a copy of the SIZE bytes of BV starting from offset START."
94 (let ((result (make-bytevector size)))
95 (bytevector-copy! bv start result 0 size)
98 (define (null-terminated-latin1->string bv)
99 "Return the volume name of SBLOCK as a string of at most 256 characters, or
100 #f if SBLOCK has no volume name."
101 ;; This is a Latin-1, nul-terminated string.
102 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
105 (list->string (map integer->char bytes)))))
109 ;;; Ext2 file systems.
112 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
113 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
115 (define-syntax %ext2-endianness
116 ;; Endianness of ext2 file systems.
117 (identifier-syntax (endianness little)))
119 (define (ext2-superblock? sblock)
120 "Return #t when SBLOCK is an ext2 superblock."
121 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
124 (define (read-ext2-superblock device)
125 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
126 if DEVICE does not contain an ext2 file system."
127 (read-superblock device 1024 264 ext2-superblock?))
129 (define (ext2-superblock-uuid sblock)
130 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
131 (sub-bytevector sblock 104 16))
133 (define (ext2-superblock-volume-name sblock)
134 "Return the volume name of SBLOCK as a string of at most 16 characters, or
135 #f if SBLOCK has no volume name."
136 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
141 ;;; LUKS encrypted devices.
144 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
145 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
146 ;; version 1.2.1 of this document.
148 (define-syntax %luks-endianness
149 ;; Endianness of LUKS headers.
150 (identifier-syntax (endianness big)))
152 (define (luks-superblock? sblock)
153 "Return #t when SBLOCK is a luks superblock."
155 ;; The 'LUKS_MAGIC' constant.
156 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
158 (let ((magic (sub-bytevector sblock 0 6))
159 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
160 (and (bytevector=? magic %luks-magic)
163 (define (read-luks-header file)
164 "Read a LUKS header from FILE. Return the raw header on success, and #f if
165 not valid header was found."
166 ;; Size in bytes of the LUKS header, including key slots.
167 (read-superblock file 0 592 luks-superblock?))
169 (define (luks-header-uuid header)
170 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
171 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
172 ;; bytes of its ASCII representation.
173 (let ((uuid (sub-bytevector header 168 36)))
174 (string->uuid (utf8->string uuid))))
178 ;;; Partition lookup.
181 (define (disk-partitions)
182 "Return the list of device names corresponding to valid disk partitions."
183 (define (last-character str)
184 (string-ref str (- (string-length str) 1)))
186 (define (partition? name major minor)
187 ;; Select device names that end in a digit, like libblkid's 'probe_all'
188 ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition"
189 ;; doesn't work for partitions coming from mapped devices.
190 (and (char-set-contains? char-set:digit (last-character name))
191 (> major 2))) ;ignore RAM disks and floppy disks
193 (call-with-input-file "/proc/partitions"
195 ;; Skip the two header lines.
199 ;; Read each subsequent line, and extract the last space-separated
201 (let loop ((parts '()))
202 (let ((line (read-line port)))
203 (if (eof-object? line)
205 (match (string-tokenize line)
206 (((= string->number major) (= string->number minor)
208 (if (partition? name major minor)
209 (loop (cons name parts))
210 (loop parts))))))))))
212 (define (ENOENT-safe proc)
213 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
214 warning and #f as the result."
220 ;; When running on the hand-made /dev,
221 ;; 'disk-partitions' could return partitions for which
222 ;; we have no /dev node. Handle that gracefully.
223 (let ((errno (system-error-errno args)))
224 (cond ((= ENOENT errno)
225 (format (current-error-port)
226 "warning: device '~a' not found~%" device)
228 ((= ENOMEDIUM errno) ;for removable media
231 (apply throw args))))))))
233 (define (partition-predicate read field =)
234 "Return a predicate that returns true if the FIELD of partition header that
235 was READ is = to the given value."
236 (let ((read (ENOENT-safe read)))
238 "Return a procedure that, when applied to a partition name such as \"sda1\",
239 returns #t if that partition's volume name is LABEL."
241 (let* ((device (string-append "/dev/" part))
242 (sblock (read device)))
244 (let ((actual (field sblock)))
246 (= actual expected)))))))))
248 (define partition-label-predicate
249 (partition-predicate read-ext2-superblock
250 ext2-superblock-volume-name
253 (define partition-uuid-predicate
254 (partition-predicate read-ext2-superblock
258 (define luks-partition-uuid-predicate
259 (partition-predicate read-luks-header
263 (define (find-partition-by-label label)
264 "Return the first partition found whose volume name is LABEL, or #f if none
266 (and=> (find (partition-label-predicate label)
268 (cut string-append "/dev/" <>)))
270 (define (find-partition-by-uuid uuid)
271 "Return the first partition whose unique identifier is UUID (a bytevector),
272 or #f if none was found."
273 (and=> (find (partition-uuid-predicate uuid)
275 (cut string-append "/dev/" <>)))
277 (define (find-partition-by-luks-uuid uuid)
278 "Return the first LUKS partition whose unique identifier is UUID (a bytevector),
279 or #f if none was found."
280 (and=> (find (luks-partition-uuid-predicate uuid)
282 (cut string-append "/dev/" <>)))
289 (define-syntax %network-byte-order
290 (identifier-syntax (endianness big)))
292 (define (uuid->string uuid)
293 "Convert UUID, a 16-byte bytevector, to its string representation, something
294 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
295 ;; See <https://tools.ietf.org/html/rfc4122>.
296 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
297 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
298 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
299 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
300 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
301 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
302 time-low time-mid time-hi clock-seq node)))
305 ;; The regexp of a UUID.
306 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
308 (define (string->uuid str)
309 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
310 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
311 UUID representation."
312 (and=> (regexp-exec %uuid-rx str)
314 (letrec-syntax ((hex->number
317 (string->number (match:substring match index)
321 ((_ bv index (number len) rest ...)
323 (bytevector-uint-set! bv index number
324 (endianness big) len)
325 (put! bv (+ index len) rest ...)))
328 (let ((time-low (hex->number 1))
329 (time-mid (hex->number 2))
330 (time-hi (hex->number 3))
331 (clock-seq (hex->number 4))
332 (node (hex->number 5))
333 (uuid (make-bytevector 16)))
335 (time-low 4) (time-mid 2) (time-hi 2)
336 (clock-seq 2) (node 6)))))))
339 (define* (canonicalize-device-spec spec #:optional (title 'any))
340 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
343 • 'device', in which case SPEC is known to designate a device node--e.g.,
345 • 'label', in which case SPEC is known to designate a partition label--e.g.,
347 • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
348 designating a partition;
349 • 'any', in which case SPEC can be anything.
352 ;; Number of times we retry partition label resolution, 1 second per
353 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
354 ;; USB key would be detected by the kernel, so we must wait for at least
358 (define canonical-title
359 ;; The realm of canonicalization.
362 ;; The "--root=SPEC" kernel command-line option always provides a
363 ;; string, but the string can represent a device, a UUID, or a
364 ;; label. So check for all three.
365 (cond ((string-prefix? "/" spec) 'device)
366 ((string->uuid spec) 'uuid)
371 (define (resolve find-partition spec fmt)
372 (let loop ((count 0))
373 (let ((device (find-partition spec)))
375 ;; Some devices take a bit of time to appear, most notably USB
376 ;; storage devices. Thus, wait for the device to appear.
377 (if (> count max-trials)
378 (error "failed to resolve partition" (fmt spec))
380 (format #t "waiting for partition '~a' to appear...~%"
383 (loop (+ 1 count))))))))
385 (case canonical-title
390 ;; Resolve the label.
391 (resolve find-partition-by-label spec identity))
393 (resolve find-partition-by-uuid
399 (error "unknown device title" title))))
401 (define (check-file-system device type)
402 "Run a file system check of TYPE on DEVICE."
404 (string-append "fsck." type))
406 (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
407 (match (status:exit-val status)
411 (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
414 (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
419 (format (current-error-port) "'~a' exited with code ~a on ~a; \
420 spawning Bourne-like REPL~%"
422 (start-repl %bournish-language)))))
424 (define (mount-flags->bit-mask flags)
425 "Return the number suitable for the 'flags' argument of 'mount' that
426 corresponds to the symbols listed in FLAGS."
427 (let loop ((flags flags))
429 (('read-only rest ...)
430 (logior MS_RDONLY (loop rest)))
431 (('bind-mount rest ...)
432 (logior MS_BIND (loop rest)))
434 (logior MS_NOSUID (loop rest)))
436 (logior MS_NODEV (loop rest)))
438 (logior MS_NOEXEC (loop rest)))
442 (define (regular-file? file-name)
443 "Return #t if FILE-NAME is a regular file."
444 (eq? (stat:type (stat file-name)) 'regular))
446 (define* (mount-file-system spec #:key (root "/root"))
447 "Mount the file system described by SPEC under ROOT. SPEC must have the
450 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
452 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
453 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
454 run a file system check."
456 (define (mount-nfs source mount-point type flags options)
457 (let* ((idx (string-rindex source #\:))
458 (host-part (string-take source idx))
459 ;; Strip [] from around host if present
460 (host (match (string-split host-part (string->char-set "[]"))
463 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
464 (sa (addrinfo:addr aa))
465 (inet-addr (inet-ntop (sockaddr:fam sa)
466 (sockaddr:addr sa))))
468 ;; Mounting an NFS file system requires passing the address
469 ;; of the server in the addr= option
470 (mount source mount-point type flags
471 (string-append "addr="
474 (string-append "," options)
477 ((source title mount-point type (flags ...) options check?)
478 (let ((source (canonicalize-device-spec source title))
479 (mount-point (string-append root "/" mount-point))
480 (flags (mount-flags->bit-mask flags)))
482 (check-file-system source type))
484 ;; Create the mount point. Most of the time this is a directory, but
485 ;; in the case of a bind mount, a regular file may be needed.
486 (if (and (= MS_BIND (logand flags MS_BIND))
487 (regular-file? source))
488 (unless (file-exists? mount-point)
489 (mkdir-p (dirname mount-point))
490 (call-with-output-file mount-point (const #t)))
491 (mkdir-p mount-point))
494 ((string-prefix? "nfs" type)
495 (mount-nfs source mount-point type flags options))
497 (mount source mount-point type flags options)))
499 ;; For read-only bind mounts, an extra remount is needed, as per
500 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
501 (when (and (= MS_BIND (logand flags MS_BIND))
502 (= MS_RDONLY (logand flags MS_RDONLY)))
503 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
504 (mount source mount-point type flags #f)))))))
506 ;;; file-systems.scm ends here