projects/guix·blob javascript-team · refs

1614 lines · 65.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014-2018, 2020-2022, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016, 2017 David Craven <[email protected]>
4;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
5;;; Copyright © 2019 Guillaume Le Vaillant <[email protected]>
6;;; Copyright © 2019–2021, 2024 Tobias Geerinckx-Rice <[email protected]>
7;;; Copyright © 2019 David C. Trudgian <[email protected]>
8;;; Copyright © 2020 Maxim Cournoyer <[email protected]>
9;;; Copyright © 2022 Oleg Pykhalov <[email protected]>
10;;; Copyright © 2024 Nicolas Graves <[email protected]>
11;;; Copyright © 2024 Richard Sent <[email protected]>
12;;; Copyright © 2024 Janneke Nieuwenhuizen <[email protected]>
13;;;
14;;; This file is part of GNU Guix.
15;;;
16;;; GNU Guix is free software; you can redistribute it and/or modify it
17;;; under the terms of the GNU General Public License as published by
18;;; the Free Software Foundation; either version 3 of the License, or (at
19;;; your option) any later version.
20;;;
21;;; GNU Guix is distributed in the hope that it will be useful, but
22;;; WITHOUT ANY WARRANTY; without even the implied warranty of
23;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24;;; GNU General Public License for more details.
25;;;
26;;; You should have received a copy of the GNU General Public License
27;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
28
29;;; Commentary:
30;;;
31;;; This modules provides tools to deal with disk partitions, and to mount and
32;;; check file systems.
33;;;
34;;; Code:
35
36(define-module (gnu build file-systems)
37 #:use-module (gnu system uuid)
38 #:use-module (gnu system file-systems)
39 #:use-module (guix build utils)
40 #:use-module (guix build bournish)
41 #:use-module ((guix build syscalls)
42 #:hide (file-system-type))
43 #:use-module (guix diagnostics)
44 #:use-module (guix i18n)
45 #:use-module (rnrs io ports)
46 #:use-module (rnrs bytevectors)
47 #:use-module (ice-9 exceptions)
48 #:use-module (ice-9 match)
49 #:use-module (ice-9 rdelim)
50 #:use-module (ice-9 regex)
51 #:use-module (ice-9 string-fun)
52 #:use-module (system foreign)
53 #:autoload (system repl repl) (start-repl)
54 #:use-module (srfi srfi-1)
55 #:use-module (srfi srfi-26)
56 #:use-module (srfi srfi-34)
57 #:use-module (srfi srfi-35)
58 #:export (disk-partitions
59 partition-label-predicate
60 partition-uuid-predicate
61 partition-luks-uuid-predicate
62 find-partition-by-label
63 find-partition-by-uuid
64 find-partition-by-luks-uuid
65 canonicalize-device-spec
66
67 device-name->hurd-device-name
68 device-spec->device
69 device-spec->device-name
70 hurd-device-name->device-name
71
72 read-partition-label
73 read-partition-uuid
74 read-luks-partition-uuid
75
76 cleanly-unmounted-ext2?
77
78 partition-lookup-error?
79 &partition-lookup-error
80
81 bind-mount
82
83 system*/tty
84 mount-flags->bit-mask
85 check-file-system
86 mount-file-system
87
88 swap-space->flags-bit-mask))
89
90(define (system*/console program . args)
91 "Run PROGRAM with ARGS in a tty on top of /dev/console. The return value is
92as for 'system*'."
93 (match (primitive-fork)
94 (0
95 (dynamic-wind
96 (const #t)
97 (lambda ()
98 (login-tty (open-fdes "/dev/console" O_RDWR))
99 (apply execlp program program args))
100 (lambda ()
101 (primitive-_exit 127))))
102 (pid
103 (cdr (waitpid pid)))))
104
105(define (system*/tty program . args)
106 "Run PROGRAM with ARGS, creating a tty if its standard input isn't one.
107The return value is as for 'system*'.
108
109This is necessary for commands such as 'cryptsetup open' or 'fsck' that may
110need to interact with the user but might be invoked from shepherd, where
111standard input is /dev/null."
112 (apply (if (isatty? (current-input-port))
113 system*
114 system*/console)
115 program args))
116
117(define (call-with-input-file file proc)
118 "Like 'call-with-input-file', but pass O_CLOEXEC."
119 (let ((port #f))
120 (dynamic-wind
121 (lambda ()
122 (set! port (open file (logior O_RDONLY O_CLOEXEC))))
123 (lambda ()
124 (proc port))
125 (lambda ()
126 (close-port port)
127 (set! port #f)))))
128
129(define (bind-mount source target)
130 "Bind-mount SOURCE at TARGET."
131 (mount source target "" MS_BIND))
132
133(define (seek* fd/port offset whence)
134 "Like 'seek' but return -1 instead of throwing to 'system-error' upon
135EINVAL. This makes it easier to catch cases like OFFSET being too large for
136FD/PORT."
137 (catch 'system-error
138 (lambda ()
139 (seek fd/port offset whence))
140 (lambda args
141 (if (= EINVAL (system-error-errno args))
142 -1
143 (apply throw args)))))
144
145(define (read-superblock device offset size magic?)
146 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
147superblock on success, and #f if no valid superblock was found. MAGIC?
148takes a bytevector and returns #t when it's a valid superblock."
149 (call-with-input-file device
150 (lambda (port)
151 (and (= offset (seek* port offset SEEK_SET))
152 (let ((block (make-bytevector size)))
153 (match (get-bytevector-n! port block 0 (bytevector-length block))
154 ((? eof-object?)
155 #f)
156 ((? number? len)
157 (and (= len (bytevector-length block))
158 (and (magic? block)
159 block)))))))))
160
161(define null-terminated-latin1->string
162 (cut latin1->string <> zero?))
163
164(define (bytevector-utf16-length bv)
165 "Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
166determine where the NUL terminator is and return its index. If there's no
167NUL terminator, return the size of the bytevector."
168 (let ((length (bytevector-length bv)))
169 (let loop ((index 0))
170 (if (< index length)
171 (if (zero? (bytevector-u16-ref bv index 'little))
172 index
173 (loop (+ index 2)))
174 length))))
175
176(define* (bytevector->u16-list bv endianness #:optional (index 0))
177 (if (< index (bytevector-length bv))
178 (cons (bytevector-u16-ref bv index endianness)
179 (bytevector->u16-list bv endianness (+ index 2)))
180 '()))
181
182;; The initrd doesn't have iconv data, so do the conversion ourselves.
183(define (utf16->string bv endianness)
184 (list->string
185 (map integer->char
186 (reverse
187 (let loop ((remainder (bytevector->u16-list bv endianness))
188 (result '()))
189 (match remainder
190 (() result)
191 ((a) (cons a result))
192 ((a b x ...)
193 (if (and (>= a #xD800) (< a #xDC00) ; high surrogate
194 (>= b #xDC00) (< b #xE000)) ; low surrogate
195 (loop x (cons (+ #x10000
196 (* #x400 (- a #xD800))
197 (- b #xDC00))
198 result))
199 (loop (cons b x) (cons a result))))))))))
200
201(define (null-terminated-utf16->string bv endianness)
202 (utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
203 endianness))
204
205;;;
206;;; EROFS file system.
207;;;
208;;; <https://erofs.docs.kernel.org/en/latest/core_ondisk.html>
209
210;; Little endian on-disk design according to
211;; Documentation/filesystems/erofs.rst in the Linux source code.
212(define-syntax %erofs-endianness
213 ;; Endianness of EROFS file systems.
214 (identifier-syntax (endianness little)))
215
216(define (erofs-superblock? sblock)
217 "Return #t when SBLOCK is an EROFS superblock."
218 (let ((magic (bytevector-u32-ref sblock 0 %erofs-endianness)))
219 (= magic #xE0F5E1E2)))
220
221(define (read-erofs-superblock device)
222 "Return the raw contents of DEVICE's EROFS superblock as a bytevector, or #f
223if DEVICE does not contain an ext2 file system."
224 (read-superblock device 1024 128 erofs-superblock?))
225
226(define (erofs-superblock-uuid sblock)
227 "Return the UUID of EROFS superblock SBLOCK as a 16-byte bytevector."
228 (sub-bytevector sblock 48 16))
229
230(define (erofs-superblock-volume-name sblock)
231 "Return the volume name of EROFS superblock SBLOCK as a string of at most 16
232characters, or #f if SBLOCK has no volume name."
233 (null-terminated-latin1->string (sub-bytevector sblock 64 16)))
234
235(define (check-erofs-file-system device force? repair)
236 "Return the health of an unmuounted F2FS file system on DEVICE. If FORCE?
237is true, check the file system even if it's marked as clean. Repair is not
238possible, it is only kept for compatibility reasons and it is ignored."
239 (match (status:exit-val
240 (apply system*/tty "fsck.erofs"
241 `(,device)))
242 (0 'pass)
243 (_ 'fatal-error)))
244
245;;;
246;;; Ext2 file systems.
247;;;
248
249;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
250;; TODO: Use "packed structs" from Guile-OpenGL or similar.
251
252(define-syntax %ext2-endianness
253 ;; Endianness of ext2 file systems.
254 (identifier-syntax (endianness little)))
255
256(define (ext2-superblock? sblock)
257 "Return #t when SBLOCK is an ext2 superblock."
258 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
259 (= magic #xef53)))
260
261(define (read-ext2-superblock device)
262 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
263if DEVICE does not contain an ext2 file system."
264 (read-superblock device 1024 264 ext2-superblock?))
265
266(define (ext2-superblock-cleanly-unmounted? sblock)
267 "Return true if SBLOCK denotes a file system that was cleanly unmounted,
268false otherwise."
269 (define EXT2_VALID_FS 1) ;cleanly unmounted
270 (define EXT2_ERROR_FS 2) ;errors detected
271
272 (define EXT3_FEATURE_INCOMPAT_RECOVER #x0004) ;journal needs recovery
273
274 (let ((state (bytevector-u16-ref sblock 58 %ext2-endianness)))
275 (cond ((= state EXT2_VALID_FS)
276 (let ((incompatible-features
277 (bytevector-u32-ref sblock 96 %ext2-endianness)))
278 (zero? (logand incompatible-features
279 EXT3_FEATURE_INCOMPAT_RECOVER))))
280 ((= state EXT2_ERROR_FS) #f)
281 (else (error "invalid ext2 superblock state" state)))))
282
283(define (ext2-superblock-uuid sblock)
284 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
285 (sub-bytevector sblock 104 16))
286
287(define (ext2-superblock-volume-name sblock)
288 "Return the volume name of ext2 superblock SBLOCK as a string of at most 16
289characters, or #f if SBLOCK has no volume name."
290 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
291
292(define (check-ext2-file-system device force? repair)
293 "Return the health of an unmounted ext2 file system on DEVICE. If FORCE? is
294true, check the file system even if it's marked as clean. If REPAIR is false,
295do not write to the file system to fix errors. If it's #t, fix all
296errors. Otherwise, fix only those considered safe to repair automatically."
297 (match (status:exit-val
298 (apply system*/tty "e2fsck" "-v" "-C" "0"
299 `(,@(if force? '("-f") '())
300 ,@(match repair
301 (#f '("-n"))
302 (#t '("-y"))
303 (_ '("-p")))
304 ,device)))
305 (0 'pass)
306 (1 'errors-corrected)
307 (2 'reboot-required)
308 (_ 'fatal-error)))
309
310(define (cleanly-unmounted-ext2? device) ;convenience procedure
311 "Return true if DEVICE is an ext2 file system and if it was cleanly
312unmounted."
313 (ext2-superblock-cleanly-unmounted? (read-ext2-superblock device)))
314
315
316;;;
317;;; Linux swap.
318;;;
319
320;; Linux "swap space" is not a file system but it has a UUID and volume name,
321;; like actual file systems, and we want to be able to look up swap partitions
322;; by UUID and by label.
323
324(define %linux-swap-magic
325 (string->utf8 "SWAPSPACE2"))
326
327;; Like 'PAGE_SIZE' in Linux, arch/x86/include/asm/page.h.
328;; XXX: This is always 4K on x86_64, i386, and ARMv7. However, on AArch64,
329;; this is determined by 'CONFIG_ARM64_PAGE_SHIFT' in the kernel, which is 12
330;; by default (4K) but can be 14 or 16.
331(define %page-size 4096)
332
333(define (linux-swap-superblock? sblock)
334 "Return #t when SBLOCK is a linux-swap superblock."
335 (and (= (bytevector-length sblock) %page-size)
336 (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
337 %linux-swap-magic)))
338
339(define (read-linux-swap-superblock device)
340 "Return the raw contents of DEVICE's linux-swap superblock as a bytevector, or #f
341if DEVICE does not contain a linux-swap file system."
342 (read-superblock device 0 %page-size linux-swap-superblock?))
343
344;; See 'union swap_header' in 'include/linux/swap.h'.
345
346(define (linux-swap-superblock-uuid sblock)
347 "Return the UUID of Linux-swap superblock SBLOCK as a 16-byte bytevector."
348 (sub-bytevector sblock (+ 1024 4 4 4) 16))
349
350(define (linux-swap-superblock-volume-name sblock)
351 "Return the label of Linux-swap superblock SBLOCK as a string."
352 (null-terminated-latin1->string
353 (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))
354
355(define (swap-space->flags-bit-mask swap)
356 "Return the number suitable for the 'flags' argument of 'mount'
357that corresponds to the swap-space SWAP."
358 (define prio-flag
359 (let ((p (swap-space-priority swap))
360 (max (ash SWAP_FLAG_PRIO_MASK (- SWAP_FLAG_PRIO_SHIFT))))
361 (if p
362 (logior SWAP_FLAG_PREFER
363 (ash (cond
364 ((< p 0)
365 (begin (warning
366 (G_ "Given swap priority ~a is
367negative, defaulting to 0.~%") p)
368 0))
369 ((> p max)
370 (begin (warning
371 (G_ "Limiting swap priority ~a to
372~a.~%")
373 p max)
374 max))
375 (else p))
376 SWAP_FLAG_PRIO_SHIFT))
377 0)))
378 (define delayed-flag
379 (if (swap-space-discard? swap)
380 SWAP_FLAG_DISCARD
381 0))
382 (logior prio-flag delayed-flag))
383
384
385;;;
386;;; Linux swap, after hibernation.
387;;;
388
389;; Linux swap space header is rewritten with a swsusp_header on
390;; hibernate, which takes the HIBERNATE_SIG signature, which is this
391;; string; see function mark_swapfiles in kernel/power/swap.c. In the
392;; linux kernel the comparison is always done on 10 bytes, which
393;; include the trailing zero in the case of HIBERNATE_SIG while not
394;; including it for %linux-swap-magic.
395(define %linux-swsuspend-magic
396 (string->utf8 "S1SUSPEND\0"))
397
398;; The kernel structure swsusp_header is duplicated from the swap header, in
399;; kernel/power/swap.c.
400(define (linux-swsuspend-superblock? sblock)
401 "Return #t when SBLOCK is a linux-swap superblock we can resume from."
402 (and (= (bytevector-length sblock) %page-size)
403 (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
404 %linux-swsuspend-magic)))
405
406;; If we want to resume through UUID and/or LABEL from swap partitions, we
407;; need to fetch UUID/LABEL from partitions with such magics.
408(define (read-linux-swsuspend-superblock device)
409 "Return the raw contents of DEVICE's linux-swsuspend superblock as a
410bytevector, or #f if DEVICE does not contain an linux-swap file system with an
411hibernation image from which we can resume."
412 (read-superblock device 0 %page-size linux-swsuspend-superblock?))
413
414;; Label and UUID information are otherwise left untouched, therefore, swap
415;; functions are reused.
416
417
418
419;;;
420;;; Bcachefs file systems.
421;;;
422
423;; <https://evilpiepirate.org/git/bcachefs-tools.git/tree/libbcachefs/bcachefs_format.h>
424
425(define-syntax %bcachefs-endianness
426 ;; Endianness of bcachefs file systems.
427 (identifier-syntax (endianness little)))
428
429(define (bcachefs-superblock? sblock)
430 "Return #t when SBLOCK is a bcachefs superblock."
431 (bytevector=? (sub-bytevector sblock 24 16)
432 #vu8(#xc6 #x85 #x73 #xf6 #x4e #x1a #x45 #xca
433 #x82 #x65 #xf5 #x7f #x48 #xba #x6d #x81)))
434
435(define (read-bcachefs-superblock device)
436 "Return the raw contents of DEVICE's bcachefs superblock as a bytevector, or #f
437if DEVICE does not contain a bcachefs file system."
438 ;; Field offsets & lengths, in bytes. There are more (and the superblock is
439 ;; extensible) but we need only some basic information here:
440 ;; 0 16 bch_csum
441 ;; 16 8 version
442 ;; 24 16 magic
443 ;; 40 16 uuid ← ‘internal’: you probably don't want this one
444 ;; 56 16 user_uuid ← ‘external’: user-visible one by which to mount
445 ;; 72 32 label
446 ;; Assume a sane file system: ignore the back-up superblock & checksums.
447 (read-superblock device 4096 104 bcachefs-superblock?))
448
449(define (bcachefs-superblock-external-uuid sblock)
450 "Return the external UUID of bcachefs superblock SBLOCK as a 16-byte
451bytevector."
452 (sub-bytevector sblock 56 16))
453
454(define (bcachefs-superblock-volume-name sblock)
455 "Return the volume name of bcachefs superblock SBLOCK as a string of at most
45632 characters, or #f if SBLOCK has no volume name."
457 (null-terminated-latin1->string (sub-bytevector sblock 72 32)))
458
459(define (check-bcachefs-file-system device force? repair)
460 "Return the health of an unmounted bcachefs file system on DEVICE. If FORCE?
461is true, check the file system even if it's marked as clean. If REPAIR is
462false, do not write to the file system to fix errors. If it's #t, fix all
463errors. Otherwise, fix only those considered safe to repair automatically."
464 (let ((ignored-bits (logior 2)) ; DEVICE was mounted read-only
465 (status
466 ;; A number, or #f on abnormal termination (e.g., assertion failure).
467 (status:exit-val
468 (apply system*/tty "bcachefs" "fsck" "-v"
469 `(,@(if force? '("-f") '())
470 ,@(match repair
471 (#f '("-n"))
472 (#t '("-y"))
473 (_ '("-p")))
474 ;; Make each multi-device member a separate argument.
475 ,@(string-split device #\:))))))
476 (match (and=> status (cut logand <> (lognot ignored-bits)))
477 (0 'pass)
478 (1 'errors-corrected)
479 (_ 'fatal-error))))
480
481
482;;;
483;;; Btrfs file systems.
484;;;
485
486;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
487
488(define-syntax %btrfs-endianness
489 ;; Endianness of btrfs file systems.
490 (identifier-syntax (endianness little)))
491
492(define (btrfs-superblock? sblock)
493 "Return #t when SBLOCK is a btrfs superblock."
494 (bytevector=? (sub-bytevector sblock 64 8)
495 (string->utf8 "_BHRfS_M")))
496
497(define (read-btrfs-superblock device)
498 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
499if DEVICE does not contain a btrfs file system."
500 (read-superblock device 65536 4096 btrfs-superblock?))
501
502(define (btrfs-superblock-uuid sblock)
503 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
504 (sub-bytevector sblock 32 16))
505
506(define (btrfs-superblock-volume-name sblock)
507 "Return the volume name of btrfs superblock SBLOCK as a string of at most 256
508characters, or #f if SBLOCK has no volume name."
509 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
510
511(define (check-btrfs-file-system device force? repair)
512 "Return the health of an unmounted btrfs file system on DEVICE. If FORCE? is
513false, return 'PASS unconditionally as btrfs claims no need for off-line checks.
514When FORCE? is true, do perform a real check. This is not recommended! See
515@uref{https://bugzilla.redhat.com/show_bug.cgi?id=625967#c8}. If REPAIR is
516false, do not write to DEVICE. If it's #t, fix any errors found. Otherwise,
517fix only those considered safe to repair automatically."
518 (if force?
519 (match (status:exit-val
520 (apply system*/tty "btrfs" "check" "--progress"
521 ;; Btrfs's ‘--force’ is not relevant to us here.
522 `(,@(match repair
523 ;; Upstream considers ALL repairs dangerous
524 ;; and will warn the user at run time.
525 (#t '("--repair"))
526 (_ '("--readonly" ; a no-op for clarity
527 ;; A 466G file system with 180G used is
528 ;; enough to kill btrfs with 6G of RAM.
529 "--mode" "lowmem")))
530 ,device)))
531 (0 'pass)
532 (_ 'fatal-error))
533 'pass))
534
535
536;;;
537;;; exFAT file systems.
538;;;
539
540;; <https://learn.microsoft.com/en-us/windows/win32/fileio/exfat-specification>.
541
542(define-syntax %exfat-endianness
543 (identifier-syntax (endianness little)))
544
545(define (exfat-superblock? sblock)
546 "Return #t when SBLOCK, a bytevector of at least length 512, is an exFAT
547superblock, called main boot sector in the exFAT specification."
548 (and (bytevector=? (string->utf8 "EXFAT ")
549 (sub-bytevector sblock 3 8)) ;FileSystemName
550 (bytevector=? (make-bytevector 53 0)
551 (sub-bytevector sblock 11 53)) ;MustBeZero
552 (bytevector=? #vu8(#x55 #xaa)
553 (sub-bytevector sblock 510 2)))) ;BootSignature
554
555(define (exfat-bytes-per-sector-shift sblock)
556 (bytevector-u8-ref sblock 108))
557
558(define (exfat-sectors-per-cluster-shift sblock)
559 (bytevector-u8-ref sblock 109))
560
561(define (exfat-root-directory-offset sblock)
562 (let ((cluster-heap-offset (bytevector-u32-ref sblock 88
563 %exfat-endianness))
564 (root-directory-cluster (bytevector-u32-ref sblock 96
565 %exfat-endianness)))
566 (define (cluster->sector cluster)
567 (let ((first-data-cluster 2))
568 (+ cluster-heap-offset (ash (- cluster first-data-cluster)
569 (exfat-sectors-per-cluster-shift sblock)))))
570 (ash (cluster->sector root-directory-cluster)
571 (exfat-bytes-per-sector-shift sblock))))
572
573(define (exfat-cluster-size sblock)
574 (ash 1 (+ (exfat-bytes-per-sector-shift sblock)
575 (exfat-sectors-per-cluster-shift sblock))))
576
577;; exFAT stores the volume name in a directory entry with no fixed location. We
578;; search an arbitrary number of entries before giving up: 128 for devices <256M
579;; (4K clusters), 1024 for those <32G (32K clusters), or 4096 for others (128K).
580;; It's silly but mostly matches what util-linux's libblkid does with its higher
581;; arbitrary number of 10,000 tries. To match that, we'd not only have to look
582;; up subsequent clusters in the FAT, but redesign this entire module not to
583;; assume that all file systems have a `superblock' that both fits neatly into
584;; RAM, and just happens to politely contain all the metadata we'll ever need.
585(define (read-exfat-superblock+root-directory-cluster device sblock)
586 "Return as a bytevector the raw contents of DEVICE's exFAT `superblock' from
587main boot sector up to the RootDirectoryCluster expected to contain the volume
588label."
589 (let* ((span (+ (exfat-root-directory-offset sblock)
590 (exfat-cluster-size sblock))))
591 (read-superblock device 0 span (const #t))))
592
593(define (read-exfat-superblock device)
594 "Return the raw contents of DEVICE's exFAT superblock as a bytevector, or #f
595if DEVICE does not contain an exFAT file system."
596 (and=> (read-superblock device 0 512 exfat-superblock?)
597 (cut read-exfat-superblock+root-directory-cluster device <>)))
598
599(define (exfat-superblock-volume-name sblock)
600 "Return as a string the volume name belonging to an exFAT file system
601beginning with bytevector SBLOCK, which includes directory entries.
602Return #f if no volume name was found within our arbitrary limit."
603 ;; Defined in section 7.3 of the exFAT specification.
604 (let ((root-directory (exfat-root-directory-offset sblock))
605 (cluster-size (exfat-cluster-size sblock))
606 (entry-size 32)) ;bytes
607 (let loop ((cluster-offset 0))
608 (if (< cluster-offset cluster-size)
609 (let ((offset (+ root-directory cluster-offset)))
610 (match (bytevector-u8-ref sblock offset)
611 ((or #x00 ;end of directory
612 #x03) ;type 3 & not in use
613 #f)
614 (#x83 ;type 3 & in use
615 (let* ((length (min 11 (bytevector-u8-ref sblock (+ 1 offset))))
616 (label (sub-bytevector sblock (+ 2 offset) (* 2 length))))
617 (utf16->string label %exfat-endianness)))
618 (_ (loop (+ entry-size offset)))))
619 #f))))
620
621(define (exfat-superblock-uuid sblock)
622 "Return the Volume Serial Number of exFAT superblock SBLOCK as a bytevector.
623This 4-byte identifier is guaranteed to exist, unlike the optional 16-byte
624Volume GUID from section 7.5 of the exFAT specification."
625 (sub-bytevector sblock 100 4))
626
627(define (check-exfat-file-system device force? repair)
628 "Return the health of an unmounted exFAT file system on DEVICE. If FORCE?
629is true, check the file system even if it's marked as clean. If REPAIR is
630false, do not write to the file system to fix errors. If it's #t, fix all
631errors. Otherwise, fix only those considered safe to repair automatically."
632 (match (status:exit-val
633 (apply system*/tty "fsck.exfat" "-sv"
634 `(,@(if force? '("-b") '())
635 ,@(match repair
636 (#f '("-n"))
637 (#t '("-y"))
638 (_ '("-p")))
639 ,device)))
640 (0 'pass)
641 (1 'errors-corrected)
642 (2 'reboot-required)
643 (_ 'fatal-error)))
644
645
646;;;
647;;; FAT32 file systems.
648;;;
649
650;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
651
652(define (fat32-superblock? sblock)
653 "Return #t when SBLOCK is a fat32 superblock."
654 (bytevector=? (sub-bytevector sblock 82 8)
655 (string->utf8 "FAT32 ")))
656
657(define (read-fat32-superblock device)
658 "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
659#f if DEVICE does not contain a fat32 file system."
660 (read-superblock device 0 90 fat32-superblock?))
661
662(define (fat32-superblock-uuid sblock)
663 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
664 (sub-bytevector sblock 67 4))
665
666(define (fat32-superblock-volume-name sblock)
667 "Return the volume name of fat superblock SBLOCK as a string of at most 11
668characters, or #f if SBLOCK has no volume name. The volume name is a latin1
669string. Trailing spaces are trimmed."
670 (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
671
672(define (check-fat-file-system device force? repair)
673 "Return the health of an unmounted FAT file system on DEVICE. FORCE? is
674ignored: a full file system scan is always performed. If REPAIR is false, do
675not write to the file system to fix errors. Otherwise, automatically fix them
676using the least destructive approach."
677 (match (status:exit-val
678 (system*/tty "fsck.vfat" "-v"
679 (match repair
680 (#f "-n")
681 (_ "-a")) ;no 'safe/#t distinction
682 device))
683 (0 'pass)
684 (1 'errors-corrected)
685 (_ 'fatal-error)))
686
687
688;;;
689;;; FAT16/FAT12 file systems.
690;;;
691
692(define (fat16-superblock? sblock)
693 "Return #t when SBLOCK is a fat16 or fat12 boot record."
694 (let ((boot-record (sub-bytevector sblock 54 8)))
695 (or (bytevector=? boot-record
696 (string->utf8 "FAT16 "))
697 (bytevector=? boot-record
698 (string->utf8 "FAT12 ")))))
699
700(define (read-fat16-superblock device)
701 "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
702#f if DEVICE does not contain a fat16 file system."
703 (read-superblock device 0 62 fat16-superblock?))
704
705(define (fat16-superblock-uuid sblock)
706 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
707 (sub-bytevector sblock 39 4))
708
709(define (fat16-superblock-volume-name sblock)
710 "Return the volume name of fat superblock SBLOCK as a string of at most 11
711characters, or #f if SBLOCK has no volume name. The volume name is a latin1
712string. Trailing spaces are trimmed."
713 (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
714 (lambda (c) #f))
715 #\space))
716
717
718;;;
719;;; ISO9660 file systems.
720;;;
721
722;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
723
724(define (iso9660-superblock? sblock)
725 "Return #t when SBLOCK is an iso9660 volume descriptor."
726 (bytevector=? (sub-bytevector sblock 1 6)
727 ;; Note: "\x01" is the volume descriptor format version
728 (string->utf8 "CD001\x01")))
729
730(define (read-iso9660-primary-volume-descriptor device offset)
731 "Find and read the first primary volume descriptor, starting at OFFSET.
732 Return #f if not found."
733 (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
734 (type-code (if sblock
735 (bytevector-u8-ref sblock 0)
736 (error (format #f
737 "Could not read ISO9660 primary
738volume descriptor from ~s"
739 device)))))
740 (match type-code
741 (255 #f) ; Volume Descriptor Set Terminator.
742 (1 sblock) ; Primary Volume Descriptor
743 (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
744
745(define (read-iso9660-superblock device)
746 "Return the raw contents of DEVICE's iso9660 primary volume descriptor
747as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
748 ;; Start reading at sector 16.
749 ;; Since we are not sure that the device contains an ISO9660 file system,
750 ;; we have to find that out first.
751 (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
752 (read-iso9660-primary-volume-descriptor device (* 2048 16))
753 #f)) ; Device does not contain an iso9660 file system.
754
755(define (iso9660-superblock-uuid sblock)
756 "Return the modification time of an iso9660 primary volume descriptor
757SBLOCK as a bytevector. If that's not set, returns the creation time."
758 ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
759 ;; Compare Grub: "2014-12-02-19-30-23-00".
760 ;; Compare blkid result: "2014-12-02-19-30-23-00".
761 ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
762 (let* ((creation-time (sub-bytevector sblock 813 17))
763 (modification-time (sub-bytevector sblock 830 17))
764 (unset-time (make-bytevector 17 0))
765 (time (if (bytevector=? unset-time modification-time)
766 creation-time
767 modification-time)))
768 (sub-bytevector time 0 16))) ; strips GMT offset.
769
770(define (iso9660-superblock-volume-name sblock)
771 "Return the volume name of iso9660 superblock SBLOCK as a string. The volume
772name is an ASCII string. Trailing spaces are trimmed."
773 ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
774 (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
775 (lambda (c) #f)) #\space))
776
777
778;;;
779;;; JFS file systems.
780;;;
781
782;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.
783
784(define-syntax %jfs-endianness
785 ;; Endianness of JFS file systems.
786 (identifier-syntax (endianness little)))
787
788(define (jfs-superblock? sblock)
789 "Return #t when SBLOCK is a JFS superblock."
790 (bytevector=? (sub-bytevector sblock 0 4)
791 (string->utf8 "JFS1")))
792
793(define (read-jfs-superblock device)
794 "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
795if DEVICE does not contain a JFS file system."
796 (read-superblock device 32768 184 jfs-superblock?))
797
798(define (jfs-superblock-uuid sblock)
799 "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
800 (sub-bytevector sblock 136 16))
801
802(define (jfs-superblock-volume-name sblock)
803 "Return the volume name of JFS superblock SBLOCK as a string of at most 16
804characters, or #f if SBLOCK has no volume name."
805 (null-terminated-latin1->string (sub-bytevector sblock 152 16)))
806
807(define (check-jfs-file-system device force? repair)
808 "Return the health of an unmounted JFS file system on DEVICE. If FORCE? is
809true, check the file system even if it's marked as clean. If REPAIR is false,
810do not write to the file system to fix errors, and replay the transaction log
811only if FORCE? is true. Otherwise, replay the transaction log before checking
812and automatically fix found errors."
813 (match (status:exit-val
814 (apply system*/tty
815 `("jfs_fsck" "-v"
816 ;; The ‘LEVEL’ logic is convoluted. To quote fsck/xchkdsk.c
817 ;; (‘-p’, ‘-a’, and ‘-r’ are aliases in every way):
818 ;; “If -f was chosen, have it override [-p] by [forcing] a
819 ;; check regardless of the outcome after the log is
820 ;; replayed”.
821 ;; “If -n is specified by itself, don't replay the journal.
822 ;; If -n is specified with [-p], replay the journal but
823 ;; don't make any other changes”.
824 ,@(if force? '("-f") '())
825 ,@(match repair
826 (#f '("-n"))
827 (_ '("-p"))) ; no 'safe/#t distinction
828 ,device)))
829 (0 'pass)
830 (1 'errors-corrected)
831 (2 'reboot-required)
832 (_ 'fatal-error)))
833
834
835;;;
836;;; F2FS (Flash-Friendly File System)
837;;;
838
839;;; https://git.kernel.org/pub/scm/linux/kernel/git/jaegeuk/f2fs.git/tree/include/linux/f2fs_fs.h
840;;; (but using xxd proved to be simpler)
841
842(define-syntax %f2fs-endianness
843 ;; Endianness of F2FS file systems
844 (identifier-syntax (endianness little)))
845
846;; F2FS actually stores two adjacent copies of the superblock.
847;; should we read both?
848(define (f2fs-superblock? sblock)
849 "Return #t when SBLOCK is an F2FS superblock."
850 (let ((magic (bytevector-u32-ref sblock 0 %f2fs-endianness)))
851 (= magic #xF2F52010)))
852
853(define (read-f2fs-superblock device)
854 "Return the raw contents of DEVICE's F2FS superblock as a bytevector, or #f
855if DEVICE does not contain an F2FS file system."
856 (read-superblock device
857 ;; offset of magic in first copy
858 #x400
859 ;; difference between magic of second
860 ;; and first copies
861 (- #x1400 #x400)
862 f2fs-superblock?))
863
864(define (f2fs-superblock-uuid sblock)
865 "Return the UUID of F2FS superblock SBLOCK as a 16-byte bytevector."
866 (sub-bytevector sblock
867 (- (+ #x460 12)
868 ;; subtract superblock offset
869 #x400)
870 16))
871
872(define (f2fs-superblock-volume-name sblock)
873 "Return the volume name of F2FS superblock SBLOCK as a string of at most 512
874characters, or #f if SBLOCK has no volume name."
875 (null-terminated-utf16->string
876 (sub-bytevector sblock (- (+ #x470 12) #x400) 512)
877 %f2fs-endianness))
878
879(define (check-f2fs-file-system device force? repair)
880 "Return the health of an unmuounted F2FS file system on DEVICE. If FORCE? is
881true, check the file system even if it's marked as clean. If either FORCE? or
882REPAIR are true, automatically fix found errors."
883 ;; There's no ‘-n’ equivalent (‘--dry-run’ does not disable writes).
884 ;; ’-y’ is an alias of ‘-f’. The man page is bad: read main.c.
885 (when (and force? (not repair))
886 (format (current-error-port)
887 "warning: forced check of F2FS ~a implies repairing any errors~%"
888 device))
889 (match (status:exit-val
890 (apply system*/tty "fsck.f2fs"
891 `(,@(if force? '("-f") '())
892 ,@(if repair '("-p") '("--dry-run"))
893 ,device)))
894 ;; 0 and -1 are the only two possibilities according to the man page.
895 (0 'pass)
896 (_ 'fatal-error)))
897
898
899;;;
900;;; LUKS encrypted devices.
901;;;
902
903;; The LUKS header format is described in "LUKS On-Disk Format Specification":
904;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
905;; version 1.2.1 of this document.
906
907;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
908;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
909;; It is a WIP document.
910
911(define-syntax %luks-endianness
912 ;; Endianness of LUKS headers.
913 (identifier-syntax (endianness big)))
914
915(define (luks-superblock? sblock)
916 "Return #t when SBLOCK is a luks superblock."
917 (define %luks-magic
918 ;; The 'LUKS_MAGIC' constant.
919 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
920 (list #xba #xbe))))
921 (let ((magic (sub-bytevector sblock 0 6))
922 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
923 (and (bytevector=? magic %luks-magic)
924 (or (= version 1) (= version 2)))))
925
926(define (read-luks-header file)
927 "Read a LUKS header from FILE. Return the raw header on success, and #f if
928not valid header was found."
929 ;; Size in bytes of the LUKS binary header, which includes key slots in
930 ;; LUKS1. In LUKS2 the binary header is partially backward compatible, so
931 ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
932 ;; not part of this header in LUKS2, but are included in the JSON metadata
933 ;; area that follows.
934 (read-superblock file 0 592 luks-superblock?))
935
936(define (luks-header-uuid header)
937 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
938 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
939 ;; bytes of its ASCII representation.
940 (let ((uuid (sub-bytevector header 168 36)))
941 (string->uuid (utf8->string uuid))))
942
943
944;;;
945;;; NTFS file systems.
946;;;
947
948;; Taken from <linux-libre>/fs/ntfs/layout.h
949
950(define-syntax %ntfs-endianness
951 ;; Endianness of NTFS file systems.
952 (identifier-syntax (endianness little)))
953
954(define (ntfs-superblock? sblock)
955 "Return #t when SBLOCK is a NTFS superblock."
956 (bytevector=? (sub-bytevector sblock 3 8)
957 (string->utf8 "NTFS ")))
958
959(define (read-ntfs-superblock device)
960 "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f
961if DEVICE does not contain a NTFS file system."
962 (read-superblock device 0 511 ntfs-superblock?))
963
964(define (ntfs-superblock-uuid sblock)
965 "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector."
966 (sub-bytevector sblock 72 8))
967
968;; TODO: Add ntfs-superblock-volume-name. The partition label is not stored
969;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
970;; way harder to access.
971
972(define (check-ntfs-file-system device force? repair)
973 "Return the health of an unmounted NTFS file system on DEVICE. FORCE? is
974ignored: a full check is always performed. Repair is not possible: if REPAIR is
975true and the volume has been repaired by an external tool, clear the volume
976dirty flag to indicate that it's now safe to mount."
977 (match (status:exit-val
978 (system*/tty "ntfsfix"
979 (if repair "--clear-dirty" "--no-action")
980 device))
981 (0 'pass)
982 (_ 'fatal-error)))
983
984
985
986;;;
987;;; XFS file systems.
988;;;
989
990;; <https://git.kernel.org/pub/scm/fs/xfs/xfs-documentation.git/tree/design/XFS_Filesystem_Structure/allocation_groups.asciidoc>
991
992(define-syntax %xfs-endianness
993 ;; Endianness of XFS file systems.
994 (identifier-syntax (endianness big)))
995
996(define (xfs-superblock? sblock)
997 "Return #t when SBLOCK is an XFS superblock."
998 (bytevector=? (sub-bytevector sblock 0 4)
999 (string->utf8 "XFSB")))
1000
1001(define (read-xfs-superblock device)
1002 "Return the raw contents of DEVICE's XFS superblock as a bytevector, or #f
1003if DEVICE does not contain an XFS file system."
1004 (read-superblock device 0 120 xfs-superblock?))
1005
1006(define (xfs-superblock-uuid sblock)
1007 "Return the UUID of XFS superblock SBLOCK as a 16-byte bytevector."
1008 (sub-bytevector sblock 32 16))
1009
1010(define (xfs-superblock-volume-name sblock)
1011 "Return the volume name of XFS superblock SBLOCK as a string of at most 12
1012characters, or #f if SBLOCK has no volume name."
1013 (null-terminated-latin1->string (sub-bytevector sblock 108 12)))
1014
1015(define (check-xfs-file-system device force? repair)
1016 "Return the health of an unmounted XFS file system on DEVICE. If FORCE? is
1017false, return 'PASS unconditionally as XFS claims no need for off-line checks.
1018When FORCE? is true, do perform a thorough check. If REPAIR is false, do not
1019write to DEVICE. If it's #t, replay the log, check, and fix any errors found.
1020Otherwise, only replay the log, and check without attempting further repairs."
1021 (define (xfs_repair)
1022 (status:exit-val
1023 (system*/tty "xfs_repair" "-Pv"
1024 (match repair
1025 (#t "-e")
1026 (_ "-n")) ;will miss some errors
1027 device)))
1028 (if force?
1029 ;; xfs_repair fails with exit status 2 if the log is dirty, which is
1030 ;; likely in situations where you're running xfs_repair. Only the kernel
1031 ;; can replay the log by {,un}mounting it cleanly.
1032 (match (let ((status (xfs_repair)))
1033 (if (and repair (eq? 2 status))
1034 (let ((target "/replay-XFS-log"))
1035 ;; The kernel helpfully prints a ‘Mounting…’ notice for us.
1036 (mkdir target)
1037 (mount device target "xfs")
1038 (umount target)
1039 (rmdir target)
1040 (xfs_repair))
1041 status))
1042 (0 'pass)
1043 (4 'errors-corrected)
1044 (_ 'fatal-error))
1045 'pass))
1046
1047
1048;;;
1049;;; Partition lookup.
1050;;;
1051
1052(define (disk-partitions)
1053 "Return the list of device names corresponding to valid disk partitions."
1054 (define (partition? name major minor)
1055 ;; grub-mkrescue does some funny things for EFI support which
1056 ;; makes it a lot more difficult than one would expect to support
1057 ;; booting an ISO-9660 image from an USB flash drive.
1058 ;; For example there's a buggy (too small) hidden partition in it
1059 ;; which Linux mounts and then proceeds to fail while trying to
1060 ;; fall off the edge.
1061 ;; In any case, partition tables are supposed to be optional so
1062 ;; here we allow checking entire disks for file systems, too.
1063 (> major 2)) ;ignore RAM disks and floppy disks
1064
1065 (call-with-input-file "/proc/partitions"
1066 (lambda (port)
1067 ;; Skip the two header lines.
1068 (read-line port)
1069 (read-line port)
1070
1071 ;; Read each subsequent line, and extract the last space-separated
1072 ;; field.
1073 (let loop ((parts '()))
1074 (let ((line (read-line port)))
1075 (if (eof-object? line)
1076 (reverse parts)
1077 (match (string-tokenize line)
1078 (((= string->number major) (= string->number minor)
1079 blocks name)
1080 (if (partition? name major minor)
1081 (loop (cons name parts))
1082 (loop parts))))))))))
1083
1084(define (ENOENT-safe proc)
1085 "Wrap the one-argument PROC such that ENOENT, EIO, and ENOMEDIUM errors are
1086caught and lead to a warning and #f as the result."
1087 (lambda (device)
1088 (catch 'system-error
1089 (lambda ()
1090 (proc device))
1091 (lambda args
1092 (let ((errno (system-error-errno args)))
1093 (cond ((= ENOENT errno)
1094 (format (current-error-port)
1095 "warning: device '~a' not found~%" device)
1096 #f)
1097 ((= ENOMEDIUM errno) ;for removable media
1098 #f)
1099 ((= EIO errno) ;unreadable hardware like audio CDs
1100 (format (current-error-port)
1101 "warning: failed to read from device '~a'~%" device)
1102 #f)
1103 ((= EMEDIUMTYPE errno) ;inaccessible, like DRBD secondaries
1104 (format (current-error-port)
1105 "warning: failed to open device '~a'~%" device)
1106 #f)
1107 (else
1108 (apply throw args))))))))
1109
1110(define (partition-field-reader read field)
1111 "Return a procedure that takes a device and returns the value of a FIELD in
1112the partition superblock or #f."
1113 (lambda (device)
1114 (let ((sblock (read device)))
1115 (and sblock
1116 (field sblock)))))
1117
1118(define (read-partition-field device partition-field-readers)
1119 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
1120takes a list of PARTITION-FIELD-READERS and returns the result of the first
1121partition field reader that returned a value."
1122 (match (filter-map (cut apply <> (list device)) partition-field-readers)
1123 ((field . _) field)
1124 (_ #f)))
1125
1126(define %partition-label-readers
1127 (list (partition-field-reader read-iso9660-superblock
1128 iso9660-superblock-volume-name)
1129 (partition-field-reader read-erofs-superblock
1130 erofs-superblock-volume-name)
1131 (partition-field-reader read-ext2-superblock
1132 ext2-superblock-volume-name)
1133 (partition-field-reader read-linux-swap-superblock
1134 linux-swap-superblock-volume-name)
1135 (partition-field-reader read-linux-swsuspend-superblock
1136 linux-swap-superblock-volume-name)
1137 (partition-field-reader read-bcachefs-superblock
1138 bcachefs-superblock-volume-name)
1139 (partition-field-reader read-btrfs-superblock
1140 btrfs-superblock-volume-name)
1141 (partition-field-reader read-exfat-superblock
1142 exfat-superblock-volume-name)
1143 (partition-field-reader read-fat32-superblock
1144 fat32-superblock-volume-name)
1145 (partition-field-reader read-fat16-superblock
1146 fat16-superblock-volume-name)
1147 (partition-field-reader read-jfs-superblock
1148 jfs-superblock-volume-name)
1149 (partition-field-reader read-f2fs-superblock
1150 f2fs-superblock-volume-name)
1151 (partition-field-reader read-xfs-superblock
1152 xfs-superblock-volume-name)))
1153
1154(define %partition-uuid-readers
1155 (list (partition-field-reader read-iso9660-superblock
1156 iso9660-superblock-uuid)
1157 (partition-field-reader read-erofs-superblock
1158 erofs-superblock-uuid)
1159 (partition-field-reader read-ext2-superblock
1160 ext2-superblock-uuid)
1161 (partition-field-reader read-linux-swap-superblock
1162 linux-swap-superblock-uuid)
1163 (partition-field-reader read-linux-swsuspend-superblock
1164 linux-swap-superblock-uuid)
1165 (partition-field-reader read-bcachefs-superblock
1166 bcachefs-superblock-external-uuid)
1167 (partition-field-reader read-btrfs-superblock
1168 btrfs-superblock-uuid)
1169 (partition-field-reader read-exfat-superblock
1170 exfat-superblock-uuid)
1171 (partition-field-reader read-fat32-superblock
1172 fat32-superblock-uuid)
1173 (partition-field-reader read-fat16-superblock
1174 fat16-superblock-uuid)
1175 (partition-field-reader read-jfs-superblock
1176 jfs-superblock-uuid)
1177 (partition-field-reader read-f2fs-superblock
1178 f2fs-superblock-uuid)
1179 (partition-field-reader read-ntfs-superblock
1180 ntfs-superblock-uuid)
1181 (partition-field-reader read-xfs-superblock
1182 xfs-superblock-uuid)))
1183
1184(define read-partition-label
1185 (cut read-partition-field <> %partition-label-readers))
1186
1187(define read-partition-uuid
1188 (cut read-partition-field <> %partition-uuid-readers))
1189
1190(define luks-partition-field-reader
1191 (partition-field-reader read-luks-header luks-header-uuid))
1192
1193(define read-luks-partition-uuid
1194 (cut read-partition-field <> (list luks-partition-field-reader)))
1195
1196(define (partition-predicate reader =)
1197 "Return a predicate that returns true if the FIELD of partition header that
1198was READ is = to the given value."
1199 ;; When running on the hand-made /dev, 'disk-partitions' could return
1200 ;; partitions for which we have no /dev node. Handle that gracefully.
1201 (let ((reader (ENOENT-safe reader)))
1202 (lambda (expected)
1203 (lambda (device)
1204 (let ((actual (reader device)))
1205 (and actual
1206 (= actual expected)))))))
1207
1208(define partition-label-predicate
1209 (partition-predicate read-partition-label string=?))
1210
1211(define partition-uuid-predicate
1212 (partition-predicate read-partition-uuid uuid=?))
1213
1214(define luks-partition-uuid-predicate
1215 (partition-predicate luks-partition-field-reader uuid=?))
1216
1217(define (find-partition predicate)
1218 "Return the first partition found that matches PREDICATE, or #f if none
1219were found."
1220 (lambda (expected)
1221 (find (predicate expected)
1222 (map (cut string-append "/dev/" <>)
1223 (disk-partitions)))))
1224
1225(define find-partition-by-label
1226 (find-partition partition-label-predicate))
1227
1228(define find-partition-by-uuid
1229 (find-partition partition-uuid-predicate))
1230
1231(define find-partition-by-luks-uuid
1232 (find-partition luks-partition-uuid-predicate))
1233
1234(define-condition-type &partition-lookup-error &condition
1235 partition-lookup-error?
1236 (spec partition-lookup-error-spec))
1237
1238
1239(define (canonicalize-device-spec spec)
1240 "Return the device name corresponding to SPEC, which can be a <uuid>, a
1241<file-system-label>, the string 'none' or another string (typically a /dev
1242file name or an nfs-root containing ':/')."
1243 (define max-trials
1244 ;; Number of times we retry partition label resolution, 1 second per
1245 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
1246 ;; USB key would be detected by the kernel, so we must wait for at least
1247 ;; this long.
1248 20)
1249
1250 (define (resolve find-partition spec fmt)
1251 (let loop ((count 0))
1252 (let ((device (find-partition spec)))
1253 (or device
1254 ;; Some devices take a bit of time to appear, most notably USB
1255 ;; storage devices. Thus, wait for the device to appear.
1256 (if (> count max-trials)
1257 (raise (condition
1258 (&partition-lookup-error
1259 (spec (fmt spec)))))
1260 (begin
1261 (format #t "waiting for partition '~a' to appear...~%"
1262 (fmt spec))
1263 (sleep 1)
1264 (loop (+ 1 count))))))))
1265
1266 (define (device-exists? device)
1267 (and (file-exists? device)
1268 device))
1269
1270 (match spec
1271 ((? string?)
1272 (if (string-match "^/dev/[a-zA-Z0-9]+$" spec)
1273 ;; Nothing to do, but wait until SPEC shows up.
1274 (resolve device-exists? spec identity)
1275 ;; Do not resolve NFS / CIFS / tmpfs devices
1276 ;; or bcachefs multi-device specifications.
1277 spec))
1278 ((? file-system-label?)
1279 ;; Resolve the label.
1280 (resolve find-partition-by-label
1281 (file-system-label->string spec)
1282 identity))
1283 ((? uuid?)
1284 (resolve find-partition-by-uuid
1285 (uuid-bytevector spec)
1286 uuid->string))))
1287
1288(define (check-file-system device type force? repair)
1289 "Check an unmounted TYPE file system on DEVICE. Do nothing but warn if it is
1290mounted. If FORCE? is true, check even when considered unnecessary. If REPAIR
1291is false, try not to write to DEVICE at all. If it's #t, try to fix all errors
1292found. Otherwise, fix only those considered safe to repair automatically. Not
1293all TYPEs support all values or combinations of FORCE? and REPAIR. Don't throw
1294an exception in such cases but perform the nearest sane action."
1295 (define check-procedure
1296 (cond
1297 ((string-prefix? "erofs" type) check-erofs-file-system)
1298 ((string-prefix? "ext" type) check-ext2-file-system)
1299 ((string-prefix? "bcachefs" type) check-bcachefs-file-system)
1300 ((string-prefix? "btrfs" type) check-btrfs-file-system)
1301 ((string-suffix? "exfat" type) check-exfat-file-system)
1302 ((string-suffix? "fat" type) check-fat-file-system)
1303 ((string-prefix? "jfs" type) check-jfs-file-system)
1304 ((string-prefix? "f2fs" type) check-f2fs-file-system)
1305 ((string-prefix? "ntfs" type) check-ntfs-file-system)
1306 ((string-prefix? "nfs" type) (const 'pass))
1307 ((string-prefix? "cifs" type) (const 'pass))
1308 ((string-prefix? "xfs" type) check-xfs-file-system)
1309 (else #f)))
1310
1311 (if check-procedure
1312 (let ((mount (find (lambda (mount)
1313 (string=? device (mount-source mount)))
1314 (mounts))))
1315 (if mount
1316 (format (current-error-port)
1317 "Refusing to check ~a file system already mounted at ~a~%"
1318 device (mount-point mount))
1319 (match (check-procedure device force? repair)
1320 ('pass
1321 #t)
1322 ('errors-corrected
1323 (format (current-error-port)
1324 "File system check corrected errors on ~a; continuing~%"
1325 device))
1326 ('reboot-required
1327 (format (current-error-port)
1328 "File system check corrected errors on ~a; rebooting~%"
1329 device)
1330 (sleep 3)
1331 (reboot))
1332 ('fatal-error
1333 (format (current-error-port) "File system check on ~a failed~%"
1334 device)
1335
1336 ;; Spawn a REPL only if someone might interact with it.
1337 (when (isatty? (current-input-port))
1338 (format (current-error-port) "Spawning Bourne-like REPL.~%")
1339
1340 ;; 'current-output-port' is typically connected to /dev/klog
1341 ;; (in PID 1), but here we want to make sure we talk directly
1342 ;; to the user.
1343 (with-output-to-file "/dev/console"
1344 (lambda ()
1345 (start-repl %bournish-language))))))))
1346 (format (current-error-port)
1347 "No file system check procedure for ~a; skipping~%"
1348 device)))
1349
1350(define (mount-flags->bit-mask flags)
1351 "Return the number suitable for the 'flags' argument of 'mount' that
1352corresponds to the symbols listed in FLAGS."
1353 (let loop ((flags flags))
1354 ;; Note: Keep in sync with ‘invalid-file-system-flags’.
1355 (match flags
1356 (('read-only rest ...)
1357 (logior MS_RDONLY (loop rest)))
1358 (('bind-mount rest ...)
1359 (logior MS_REC (logior MS_BIND (loop rest))))
1360 (('no-suid rest ...)
1361 (logior MS_NOSUID (loop rest)))
1362 (('no-dev rest ...)
1363 (logior MS_NODEV (loop rest)))
1364 (('no-exec rest ...)
1365 (logior MS_NOEXEC (loop rest)))
1366 (('no-atime rest ...)
1367 (logior MS_NOATIME (loop rest)))
1368 (('no-diratime rest ...)
1369 (logior MS_NODIRATIME (loop rest)))
1370 (('strict-atime rest ...)
1371 (logior MS_STRICTATIME (loop rest)))
1372 (('lazy-time rest ...)
1373 (logior MS_LAZYTIME (loop rest)))
1374 (('remount rest ...)
1375 (logior MS_REMOUNT (loop rest)))
1376 (('shared rest ...)
1377 (loop rest))
1378 (()
1379 0))))
1380
1381(define kind-and-args-exception?
1382 (exception-predicate &exception-with-kind-and-args))
1383
1384(define (system-error? exception)
1385 "Return true if EXCEPTION is a Guile 'system-error exception."
1386 (and (kind-and-args-exception? exception)
1387 (eq? 'system-error (exception-kind exception))))
1388
1389(define* (mount-file-system fs #:key (root "/root")
1390 (check? (file-system-check? fs))
1391 (skip-check-if-clean?
1392 (file-system-skip-check-if-clean? fs))
1393 (repair (file-system-repair fs)))
1394 "Mount the file system described by FS, a <file-system> object, under ROOT."
1395
1396 (define* (host-to-ip host #:optional service)
1397 "Return the IP address for host, which may be an IP address or a hostname."
1398 (let* ((aa (match (getaddrinfo host service) ((x . _) x)))
1399 (sa (addrinfo:addr aa))
1400 (inet-addr (inet-ntop (sockaddr:fam sa)
1401 (sockaddr:addr sa))))
1402 inet-addr))
1403
1404 (define (mount-nfs source mount-point type flags options)
1405 (let* ((idx (string-rindex source #\:))
1406 (host-part (string-take source idx))
1407 ;; Strip [] from around host if present
1408 (host (match (string-split host-part (string->char-set "[]"))
1409 (("" h "") h)
1410 ((h) h)))
1411 (inet-addr (host-to-ip host "nfs")))
1412 ;; Mounting an NFS file system requires passing the address
1413 ;; of the server in the addr= option
1414 (mount source mount-point type flags
1415 (string-append "addr="
1416 inet-addr
1417 (if options
1418 (string-append "," options)
1419 "")))))
1420
1421 (define (read-cifs-credential-file file)
1422 ;; Read password, user and domain options from file
1423 ;;
1424 ;; XXX: As of version 7.0, mount.cifs strips all lines of leading
1425 ;; whitespace, parses those starting with "pass", "user" and "dom" into
1426 ;; "pass=", "user=" and "domain=" options respectively and ignores
1427 ;; everything else. To simplify the implementation, we pass those lines
1428 ;; as is. As a consequence, the "password2" option can be specified in a
1429 ;; credential file with the expected semantics (see:
1430 ;; https://issues.guix.gnu.org/71594#3).
1431 (with-input-from-file file
1432 (lambda ()
1433 (let loop
1434 ((next-line (read-line))
1435 (lines '()))
1436 (match next-line
1437 ((? eof-object?)
1438 lines)
1439 ((= string-trim line)
1440 (loop (read-line)
1441 (cond
1442 ((string-prefix? "pass" line)
1443 ;; mount.cifs escapes commas in the password by doubling
1444 ;; them
1445 (cons (string-replace-substring line "," ",,")
1446 lines))
1447 ((or (string-prefix? "user" line)
1448 (string-prefix? "dom" line))
1449 (cons line lines))
1450 ;; Ignore all other lines.
1451 (else
1452 lines)))))))))
1453
1454 (define (mount-cifs source mount-point type flags options)
1455 ;; Source is of form "//<server-ip-or-host>/<service>"
1456 (let* ((regex-match (string-match "//([^/]+)/(.+)" source))
1457 (server (match:substring regex-match 1))
1458 (share (match:substring regex-match 2))
1459 ;; Match ",guest,", ",guest$", "^guest,", or "^guest$," not
1460 ;; e.g. user=foo,pass=notaguest
1461 (guest? (string-match "(^|,)(guest)($|,)" options))
1462 (credential-file (and=> (string-match "(^|,)(credentials|cred)=([^,]+)(,|$)"
1463 options)
1464 (cut match:substring <> 3)))
1465 ;; Perform DNS resolution now instead of attempting kernel dns
1466 ;; resolver upcalling. /sbin/request-key does not exist and the
1467 ;; kernel hardcodes the path.
1468 ;;
1469 ;; (getaddrinfo) doesn't support cifs service, so omit it.
1470 (inet-addr (host-to-ip server)))
1471 (mount source mount-point type flags
1472 (string-append "ip="
1473 inet-addr
1474 ;; As of Linux af1a3d2ba9 (v5.11) unc is ignored
1475 ;; and source is parsed by the kernel
1476 ;; directly. Pass it for compatibility.
1477 ",unc="
1478 ;; Match format of mount.cifs's mount syscall.
1479 "\\\\" server "\\" share
1480 (if guest?
1481 ",user=,pass="
1482 "")
1483 (if options
1484 ;; No need to delete "guest" from options.
1485 ;; linux/fs/smb/client/fs_context.c explicitly
1486 ;; ignores it. Also, avoiding excess commas
1487 ;; when deleting is a pain.
1488 (string-append "," options)
1489 "")
1490 (if credential-file
1491 ;; The "credentials" option is ignored too.
1492 (string-join (read-cifs-credential-file credential-file)
1493 "," 'prefix)
1494 "")))))
1495
1496 (guard (c ((partition-lookup-error? c)
1497 (format (current-error-port)
1498 "could not find the partition: ~a~%"
1499 (partition-lookup-error-spec c))
1500 (unless (file-system-mount-may-fail? fs)
1501 (raise c)))
1502 ((system-error? c)
1503 (format (current-error-port)
1504 "could not mount partition '~a': ~a~%"
1505 (file-system-device fs)
1506 (string-trim-both
1507 (call-with-output-string
1508 (lambda (port)
1509 (print-exception port #f
1510 (exception-kind c)
1511 (exception-args c))))))
1512 (unless (file-system-mount-may-fail? fs)
1513 (raise c))))
1514 (let* ((type (file-system-type fs))
1515 (source (canonicalize-device-spec (file-system-device fs)))
1516 (target (string-append root "/"
1517 (file-system-mount-point fs)))
1518 (flags (logior (mount-flags->bit-mask (file-system-flags fs))
1519
1520 ;; For bind mounts, preserve the original flags such
1521 ;; as MS_NOSUID, etc. Failing to do that, the
1522 ;; MS_REMOUNT call below fails with EPERM.
1523 ;; See <https://bugs.gnu.org/46292>
1524 (if (memq 'bind-mount (file-system-flags fs))
1525 (statfs-flags->mount-flags
1526 (file-system-mount-flags (statfs source)))
1527 0)))
1528 (options (file-system-options fs)))
1529 (when check?
1530 (check-file-system source type (not skip-check-if-clean?) repair))
1531
1532 ;; Create the mount point. Most of the time this is a directory, but
1533 ;; in the case of a bind mount, a regular file or socket may be
1534 ;; needed.
1535 (if (and (= MS_BIND (logand flags MS_BIND))
1536 (not (file-is-directory? source)))
1537 (unless (file-exists? target)
1538 (mkdir-p (dirname target))
1539 (close-fdes
1540 (open-fdes target (logior O_WRONLY O_CREAT O_CLOEXEC))))
1541 (mkdir-p target))
1542
1543 (cond
1544 ((string-prefix? "nfs" type)
1545 (mount-nfs source target type flags options))
1546 ((string-prefix? "cifs" type)
1547 (mount-cifs source target type flags options))
1548 ((memq 'shared (file-system-flags fs))
1549 (mount source target type flags options)
1550 (mount "none" target #f MS_SHARED))
1551 (else
1552 (mount source target type flags options)))
1553
1554 ;; For read-only bind mounts, an extra remount is needed, as per
1555 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
1556 ;; 4.0.
1557 (when (and (= MS_BIND (logand flags MS_BIND))
1558 (= MS_RDONLY (logand flags MS_RDONLY)))
1559 (let ((flags (logior MS_REMOUNT flags)))
1560 (mount source target type flags options))))))
1561
1562(define %device-name-regexp "/dev/[hsvw]d([abcd])([0-9]*)")
1563(define %hurd-device-name-regexp "part:([0-9]*):device:[hw]d([0-9]*)")
1564
1565(define (device-spec->device-name device-spec)
1566 "Return DEVICE-SPEC as a Linux /dev/XdYZ device name, also catering for uuid
1567or label."
1568 (cond ((string-match %device-name-regexp device-spec)
1569 device-spec)
1570 ((string-match %hurd-device-name-regexp device-spec)
1571 (hurd-device-name->device-name device-spec))
1572 ((string->uuid device-spec)
1573 =>
1574 (lambda (uuid) (false-if-exception (find-partition-by-uuid uuid))))
1575 (else
1576 (false-if-exception (find-partition-by-label device-spec)))))
1577
1578(define* (device-name->hurd-device-name device-name #:key (disk "w"))
1579 "Return DEVICE-NAME as a Hurd device name:
1580 part:PART-NUMBER:device:DISKdDISK-INDEX
1581Default to part:1:device:DISKd0 if partition cannot be found."
1582 (let* ((m (and=> device-name (cute string-match %device-name-regexp <>)))
1583 (disk-char (and m (and=> (match:substring m 1)
1584 (compose car string->list))))
1585 (disk-index (or (and disk-char
1586 (- (char->integer disk-char) (char->integer #\a)))
1587 0))
1588 (partition-number (or (and m (and=> (match:substring m 2)
1589 string->number))
1590 1)))
1591 (format #f "part:~a:device:~ad~a" partition-number disk disk-index)))
1592
1593(define* (hurd-device-name->device-name device-name #:key (disk "s"))
1594 (let* ((m (and=> device-name (cute string-match %hurd-device-name-regexp <>)))
1595 (disk-index-string (and=> m (cute match:substring <> 2)))
1596 (disk-index (or (and=> disk-index-string string->number)
1597 0))
1598 (disk-index-char (integer->char (+ disk-index (char->integer #\a))))
1599 (partition-string (and=> m (cute match:substring <> 1)))
1600 (partition-number (or (and=> partition-string string->number)
1601 1)))
1602 (format #f "/dev/~ad~a~a" disk disk-index-char partition-number)))
1603
1604(define (device-spec->device device-spec)
1605 "Return DEVICE-SPEC as UUID, FILE-SYSTEM-LABEL, or DEVICE-SPEC."
1606 (cond ((and=> (string->uuid device-spec)
1607 find-partition-by-uuid)
1608 (string->uuid device-spec))
1609 ((find-partition-by-label device-spec)
1610 (file-system-label device-spec))
1611 (else
1612 device-spec)))
1613
1614;;; file-systems.scm ends here