1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
4 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 (define-module (gnu build file-systems)
22 #:use-module (gnu system uuid)
23 #:use-module (gnu system file-systems)
24 #:use-module (guix build utils)
25 #:use-module (guix build bournish)
26 #:use-module ((guix build syscalls)
27 #:hide (file-system-type))
28 #:use-module (rnrs io ports)
29 #:use-module (rnrs bytevectors)
30 #:use-module (ice-9 match)
31 #:use-module (ice-9 rdelim)
32 #:use-module (system foreign)
33 #:autoload (system repl repl) (start-repl)
34 #:use-module (srfi srfi-1)
35 #:use-module (srfi srfi-26)
36 #:export (disk-partitions
37 partition-label-predicate
38 partition-uuid-predicate
39 partition-luks-uuid-predicate
40 find-partition-by-label
41 find-partition-by-uuid
42 find-partition-by-luks-uuid
43 canonicalize-device-spec
53 ;;; This modules provides tools to deal with disk partitions, and to mount and
54 ;;; check file systems.
58 (define (bind-mount source target)
59 "Bind-mount SOURCE at TARGET."
60 (mount source target "" MS_BIND))
62 (define (seek* fd/port offset whence)
63 "Like 'seek' but return -1 instead of throwing to 'system-error' upon
64 EINVAL. This makes it easier to catch cases like OFFSET being too large for
68 (seek fd/port offset whence))
70 (if (= EINVAL (system-error-errno args))
72 (apply throw args)))))
74 (define (read-superblock device offset size magic?)
75 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
76 superblock on success, and #f if no valid superblock was found. MAGIC?
77 takes a bytevector and returns #t when it's a valid superblock."
78 (call-with-input-file device
80 (and (= offset (seek* port offset SEEK_SET))
81 (let ((block (make-bytevector size)))
82 (match (get-bytevector-n! port block 0 (bytevector-length block))
86 (and (= len (bytevector-length block))
90 (define null-terminated-latin1->string
91 (cut latin1->string <> zero?))
95 ;;; Ext2 file systems.
98 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
99 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
101 (define-syntax %ext2-endianness
102 ;; Endianness of ext2 file systems.
103 (identifier-syntax (endianness little)))
105 (define (ext2-superblock? sblock)
106 "Return #t when SBLOCK is an ext2 superblock."
107 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
110 (define (read-ext2-superblock device)
111 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
112 if DEVICE does not contain an ext2 file system."
113 (read-superblock device 1024 264 ext2-superblock?))
115 (define (ext2-superblock-uuid sblock)
116 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
117 (sub-bytevector sblock 104 16))
119 (define (ext2-superblock-volume-name sblock)
120 "Return the volume name of SBLOCK as a string of at most 16 characters, or
121 #f if SBLOCK has no volume name."
122 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
124 (define (check-ext2-file-system device)
125 "Return the health of an ext2 file system on DEVICE."
126 (match (status:exit-val
127 (system* "e2fsck" "-v" "-p" "-C" "0" device))
129 (1 'errors-corrected)
135 ;;; Btrfs file systems.
138 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
140 (define-syntax %btrfs-endianness
141 ;; Endianness of btrfs file systems.
142 (identifier-syntax (endianness little)))
144 (define (btrfs-superblock? sblock)
145 "Return #t when SBLOCK is a btrfs superblock."
146 (bytevector=? (sub-bytevector sblock 64 8)
147 (string->utf8 "_BHRfS_M")))
149 (define (read-btrfs-superblock device)
150 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
151 if DEVICE does not contain a btrfs file system."
152 (read-superblock device 65536 4096 btrfs-superblock?))
154 (define (btrfs-superblock-uuid sblock)
155 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
156 (sub-bytevector sblock 32 16))
158 (define (btrfs-superblock-volume-name sblock)
159 "Return the volume name of SBLOCK as a string of at most 256 characters, or
160 #f if SBLOCK has no volume name."
161 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
163 (define (check-btrfs-file-system device)
164 "Return the health of a btrfs file system on DEVICE."
165 (match (status:exit-val
166 (system* "btrfs" "device" "scan"))
172 ;;; FAT32 file systems.
175 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
177 (define (fat32-superblock? sblock)
178 "Return #t when SBLOCK is a fat32 superblock."
179 (bytevector=? (sub-bytevector sblock 82 8)
180 (string->utf8 "FAT32 ")))
182 (define (read-fat32-superblock device)
183 "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
184 #f if DEVICE does not contain a fat32 file system."
185 (read-superblock device 0 90 fat32-superblock?))
187 (define (fat32-superblock-uuid sblock)
188 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
189 (sub-bytevector sblock 67 4))
191 (define (fat32-superblock-volume-name sblock)
192 "Return the volume name of SBLOCK as a string of at most 11 characters, or
193 #f if SBLOCK has no volume name. The volume name is a latin1 string.
194 Trailing spaces are trimmed."
195 (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
197 (define (check-fat-file-system device)
198 "Return the health of a fat file system on DEVICE."
199 (match (status:exit-val
200 (system* "fsck.vfat" "-v" "-a" device))
202 (1 'errors-corrected)
207 ;;; FAT16 file systems.
210 (define (fat16-superblock? sblock)
211 "Return #t when SBLOCK is a fat16 boot record."
212 (bytevector=? (sub-bytevector sblock 54 8)
213 (string->utf8 "FAT16 ")))
215 (define (read-fat16-superblock device)
216 "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
217 #f if DEVICE does not contain a fat16 file system."
218 (read-superblock device 0 62 fat16-superblock?))
220 (define (fat16-superblock-uuid sblock)
221 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
222 (sub-bytevector sblock 39 4))
224 (define (fat16-superblock-volume-name sblock)
225 "Return the volume name of SBLOCK as a string of at most 11 characters, or
226 #f if SBLOCK has no volume name. The volume name is a latin1 string.
227 Trailing spaces are trimmed."
228 (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
234 ;;; ISO9660 file systems.
237 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
239 (define (iso9660-superblock? sblock)
240 "Return #t when SBLOCK is an iso9660 volume descriptor."
241 (bytevector=? (sub-bytevector sblock 1 6)
242 ;; Note: "\x01" is the volume descriptor format version
243 (string->utf8 "CD001\x01")))
245 (define (read-iso9660-primary-volume-descriptor device offset)
246 "Find and read the first primary volume descriptor, starting at OFFSET.
247 Return #f if not found."
248 (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
249 (type-code (if sblock
250 (bytevector-u8-ref sblock 0)
252 "Could not read ISO9660 primary
253 volume descriptor from ~s"
256 (255 #f) ; Volume Descriptor Set Terminator.
257 (1 sblock) ; Primary Volume Descriptor
258 (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
260 (define (read-iso9660-superblock device)
261 "Return the raw contents of DEVICE's iso9660 primary volume descriptor
262 as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
263 ;; Start reading at sector 16.
264 ;; Since we are not sure that the device contains an ISO9660 file system,
265 ;; we have to find that out first.
266 (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
267 (read-iso9660-primary-volume-descriptor device (* 2048 16))
268 #f)) ; Device does not contain an iso9660 file system.
270 (define (iso9660-superblock-uuid sblock)
271 "Return the modification time of an iso9660 primary volume descriptor
272 SBLOCK as a bytevector. If that's not set, returns the creation time."
273 ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
274 ;; Compare Grub: "2014-12-02-19-30-23-00".
275 ;; Compare blkid result: "2014-12-02-19-30-23-00".
276 ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
277 (let* ((creation-time (sub-bytevector sblock 813 17))
278 (modification-time (sub-bytevector sblock 830 17))
279 (unset-time (make-bytevector 17 0))
280 (time (if (bytevector=? unset-time modification-time)
283 (sub-bytevector time 0 16))) ; strips GMT offset.
285 (define (iso9660-superblock-volume-name sblock)
286 "Return the volume name of SBLOCK as a string. The volume name is an ASCII
287 string. Trailing spaces are trimmed."
288 ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
289 (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
290 (lambda (c) #f)) #\space))
294 ;;; LUKS encrypted devices.
297 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
298 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
299 ;; version 1.2.1 of this document.
301 (define-syntax %luks-endianness
302 ;; Endianness of LUKS headers.
303 (identifier-syntax (endianness big)))
305 (define (luks-superblock? sblock)
306 "Return #t when SBLOCK is a luks superblock."
308 ;; The 'LUKS_MAGIC' constant.
309 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
311 (let ((magic (sub-bytevector sblock 0 6))
312 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
313 (and (bytevector=? magic %luks-magic)
316 (define (read-luks-header file)
317 "Read a LUKS header from FILE. Return the raw header on success, and #f if
318 not valid header was found."
319 ;; Size in bytes of the LUKS header, including key slots.
320 (read-superblock file 0 592 luks-superblock?))
322 (define (luks-header-uuid header)
323 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
324 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
325 ;; bytes of its ASCII representation.
326 (let ((uuid (sub-bytevector header 168 36)))
327 (string->uuid (utf8->string uuid))))
331 ;;; Partition lookup.
334 (define (disk-partitions)
335 "Return the list of device names corresponding to valid disk partitions."
336 (define (partition? name major minor)
337 ;; grub-mkrescue does some funny things for EFI support which
338 ;; makes it a lot more difficult than one would expect to support
339 ;; booting an ISO-9660 image from an USB flash drive.
340 ;; For example there's a buggy (too small) hidden partition in it
341 ;; which Linux mounts and then proceeds to fail while trying to
342 ;; fall off the edge.
343 ;; In any case, partition tables are supposed to be optional so
344 ;; here we allow checking entire disks for file systems, too.
345 (> major 2)) ;ignore RAM disks and floppy disks
347 (call-with-input-file "/proc/partitions"
349 ;; Skip the two header lines.
353 ;; Read each subsequent line, and extract the last space-separated
355 (let loop ((parts '()))
356 (let ((line (read-line port)))
357 (if (eof-object? line)
359 (match (string-tokenize line)
360 (((= string->number major) (= string->number minor)
362 (if (partition? name major minor)
363 (loop (cons name parts))
364 (loop parts))))))))))
366 (define (ENOENT-safe proc)
367 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
368 warning and #f as the result."
374 ;; When running on the hand-made /dev,
375 ;; 'disk-partitions' could return partitions for which
376 ;; we have no /dev node. Handle that gracefully.
377 (let ((errno (system-error-errno args)))
378 (cond ((= ENOENT errno)
379 (format (current-error-port)
380 "warning: device '~a' not found~%" device)
382 ((= ENOMEDIUM errno) ;for removable media
384 ((= EIO errno) ;unreadable hardware like audio CDs
385 (format (current-error-port)
386 "warning: failed to read from device '~a'~%" device)
389 (apply throw args))))))))
391 (define (partition-field-reader read field)
392 "Return a procedure that takes a device and returns the value of a FIELD in
393 the partition superblock or #f."
394 (let ((read (ENOENT-safe read)))
396 (let ((sblock (read device)))
400 (define (read-partition-field device partition-field-readers)
401 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
402 takes a list of PARTITION-FIELD-READERS and returns the result of the first
403 partition field reader that returned a value."
404 (match (filter-map (cut apply <> (list device)) partition-field-readers)
408 (define %partition-label-readers
409 (list (partition-field-reader read-iso9660-superblock
410 iso9660-superblock-volume-name)
411 (partition-field-reader read-ext2-superblock
412 ext2-superblock-volume-name)
413 (partition-field-reader read-btrfs-superblock
414 btrfs-superblock-volume-name)
415 (partition-field-reader read-fat32-superblock
416 fat32-superblock-volume-name)
417 (partition-field-reader read-fat16-superblock
418 fat16-superblock-volume-name)))
420 (define %partition-uuid-readers
421 (list (partition-field-reader read-iso9660-superblock
422 iso9660-superblock-uuid)
423 (partition-field-reader read-ext2-superblock
424 ext2-superblock-uuid)
425 (partition-field-reader read-btrfs-superblock
426 btrfs-superblock-uuid)
427 (partition-field-reader read-fat32-superblock
428 fat32-superblock-uuid)
429 (partition-field-reader read-fat16-superblock
430 fat16-superblock-uuid)))
432 (define read-partition-label
433 (cut read-partition-field <> %partition-label-readers))
435 (define read-partition-uuid
436 (cut read-partition-field <> %partition-uuid-readers))
438 (define (partition-predicate reader =)
439 "Return a predicate that returns true if the FIELD of partition header that
440 was READ is = to the given value."
443 (let ((actual (reader device)))
445 (= actual expected))))))
447 (define partition-label-predicate
448 (partition-predicate read-partition-label string=?))
450 (define partition-uuid-predicate
451 (partition-predicate read-partition-uuid uuid=?))
453 (define luks-partition-uuid-predicate
455 (partition-field-reader read-luks-header luks-header-uuid)
458 (define (find-partition predicate)
459 "Return the first partition found that matches PREDICATE, or #f if none
462 (find (predicate expected)
463 (map (cut string-append "/dev/" <>)
464 (disk-partitions)))))
466 (define find-partition-by-label
467 (find-partition partition-label-predicate))
469 (define find-partition-by-uuid
470 (find-partition partition-uuid-predicate))
472 (define find-partition-by-luks-uuid
473 (find-partition luks-partition-uuid-predicate))
476 (define (canonicalize-device-spec spec)
477 "Return the device name corresponding to SPEC, which can be a <uuid>, a
478 <file-system-label>, or a string (typically a /dev file name)."
480 ;; Number of times we retry partition label resolution, 1 second per
481 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
482 ;; USB key would be detected by the kernel, so we must wait for at least
486 (define (resolve find-partition spec fmt)
487 (let loop ((count 0))
488 (let ((device (find-partition spec)))
490 ;; Some devices take a bit of time to appear, most notably USB
491 ;; storage devices. Thus, wait for the device to appear.
492 (if (> count max-trials)
493 (error "failed to resolve partition" (fmt spec))
495 (format #t "waiting for partition '~a' to appear...~%"
498 (loop (+ 1 count))))))))
502 ;; Nothing to do, but wait until SPEC shows up.
503 (resolve identity spec identity))
504 ((? file-system-label?)
505 ;; Resolve the label.
506 (resolve find-partition-by-label
507 (file-system-label->string spec)
510 (resolve find-partition-by-uuid
511 (uuid-bytevector spec)
514 (define (check-file-system device type)
515 "Run a file system check of TYPE on DEVICE."
516 (define check-procedure
518 ((string-prefix? "ext" type) check-ext2-file-system)
519 ((string-prefix? "btrfs" type) check-btrfs-file-system)
520 ((string-suffix? "fat" type) check-fat-file-system)
524 (match (check-procedure device)
528 (format (current-error-port)
529 "File system check corrected errors on ~a; continuing~%"
532 (format (current-error-port)
533 "File system check corrected errors on ~a; rebooting~%"
538 (format (current-error-port)
539 "File system check on ~a failed; spawning Bourne-like REPL~%"
541 (start-repl %bournish-language)))
542 (format (current-error-port)
543 "No file system check procedure for ~a; skipping~%"
546 (define (mount-flags->bit-mask flags)
547 "Return the number suitable for the 'flags' argument of 'mount' that
548 corresponds to the symbols listed in FLAGS."
549 (let loop ((flags flags))
551 (('read-only rest ...)
552 (logior MS_RDONLY (loop rest)))
553 (('bind-mount rest ...)
554 (logior MS_BIND (loop rest)))
556 (logior MS_NOSUID (loop rest)))
558 (logior MS_NODEV (loop rest)))
560 (logior MS_NOEXEC (loop rest)))
564 (define* (mount-file-system fs #:key (root "/root"))
565 "Mount the file system described by FS, a <file-system> object, under ROOT.
567 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
568 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
569 run a file system check."
571 (define (mount-nfs source mount-point type flags options)
572 (let* ((idx (string-rindex source #\:))
573 (host-part (string-take source idx))
574 ;; Strip [] from around host if present
575 (host (match (string-split host-part (string->char-set "[]"))
578 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
579 (sa (addrinfo:addr aa))
580 (inet-addr (inet-ntop (sockaddr:fam sa)
581 (sockaddr:addr sa))))
583 ;; Mounting an NFS file system requires passing the address
584 ;; of the server in the addr= option
585 (mount source mount-point type flags
586 (string-append "addr="
589 (string-append "," options)
591 (let ((type (file-system-type fs))
592 (options (file-system-options fs))
593 (source (canonicalize-device-spec (file-system-device fs)))
594 (mount-point (string-append root "/"
595 (file-system-mount-point fs)))
596 (flags (mount-flags->bit-mask (file-system-flags fs))))
597 (when (file-system-check? fs)
598 (check-file-system source type))
600 ;; Create the mount point. Most of the time this is a directory, but
601 ;; in the case of a bind mount, a regular file or socket may be needed.
602 (if (and (= MS_BIND (logand flags MS_BIND))
603 (not (file-is-directory? source)))
604 (unless (file-exists? mount-point)
605 (mkdir-p (dirname mount-point))
606 (call-with-output-file mount-point (const #t)))
607 (mkdir-p mount-point))
610 ((string-prefix? "nfs" type)
611 (mount-nfs source mount-point type flags options))
613 (mount source mount-point type flags options)))
615 ;; For read-only bind mounts, an extra remount is needed, as per
616 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
617 (when (and (= MS_BIND (logand flags MS_BIND))
618 (= MS_RDONLY (logand flags MS_RDONLY)))
619 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
620 (mount source mount-point type flags #f)))))
622 ;;; file-systems.scm ends here