1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017 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 (guix build utils)
23 #:use-module (guix build bournish)
24 #:use-module (guix build syscalls)
25 #:use-module (rnrs io ports)
26 #:use-module (rnrs bytevectors)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 rdelim)
29 #:use-module (ice-9 format)
30 #:use-module (ice-9 regex)
31 #:use-module (system foreign)
32 #:autoload (system repl repl) (start-repl)
33 #:use-module (srfi srfi-1)
34 #:use-module (srfi srfi-26)
35 #:export (disk-partitions
36 partition-label-predicate
37 partition-uuid-predicate
38 partition-luks-uuid-predicate
39 find-partition-by-label
40 find-partition-by-uuid
41 find-partition-by-luks-uuid
42 canonicalize-device-spec
55 ;;; This modules provides tools to deal with disk partitions, and to mount and
56 ;;; check file systems.
60 (define (bind-mount source target)
61 "Bind-mount SOURCE at TARGET."
62 (mount source target "" MS_BIND))
64 (define (seek* fd/port offset whence)
65 "Like 'seek' but return -1 instead of throwing to 'system-error' upon
66 EINVAL. This makes it easier to catch cases like OFFSET being too large for
70 (seek fd/port offset whence))
72 (if (= EINVAL (system-error-errno args))
74 (apply throw args)))))
76 (define (read-superblock device offset size magic?)
77 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
78 superblock on success, and #f if no valid superblock was found. MAGIC?
79 takes a bytevector and returns #t when it's a valid superblock."
80 (call-with-input-file device
82 (and (= offset (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 (latin1->string bv terminator)
99 "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate
100 that takes a number and returns #t when a termination character is found."
101 (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
104 (list->string (map integer->char bytes)))))
106 (define null-terminated-latin1->string
107 (cut latin1->string <> zero?))
111 ;;; Ext2 file systems.
114 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
115 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
117 (define-syntax %ext2-endianness
118 ;; Endianness of ext2 file systems.
119 (identifier-syntax (endianness little)))
121 (define (ext2-superblock? sblock)
122 "Return #t when SBLOCK is an ext2 superblock."
123 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
126 (define (read-ext2-superblock device)
127 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
128 if DEVICE does not contain an ext2 file system."
129 (read-superblock device 1024 264 ext2-superblock?))
131 (define (ext2-superblock-uuid sblock)
132 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
133 (sub-bytevector sblock 104 16))
135 (define (ext2-superblock-volume-name sblock)
136 "Return the volume name of SBLOCK as a string of at most 16 characters, or
137 #f if SBLOCK has no volume name."
138 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
140 (define (check-ext2-file-system device)
141 "Return the health of an ext2 file system on DEVICE."
142 (match (status:exit-val
143 (system* "e2fsck" "-v" "-p" "-C" "0" device))
145 (1 'errors-corrected)
151 ;;; Btrfs file systems.
154 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
156 (define-syntax %btrfs-endianness
157 ;; Endianness of btrfs file systems.
158 (identifier-syntax (endianness little)))
160 (define (btrfs-superblock? sblock)
161 "Return #t when SBLOCK is a btrfs superblock."
162 (bytevector=? (sub-bytevector sblock 64 8)
163 (string->utf8 "_BHRfS_M")))
165 (define (read-btrfs-superblock device)
166 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
167 if DEVICE does not contain a btrfs file system."
168 (read-superblock device 65536 4096 btrfs-superblock?))
170 (define (btrfs-superblock-uuid sblock)
171 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
172 (sub-bytevector sblock 32 16))
174 (define (btrfs-superblock-volume-name sblock)
175 "Return the volume name of SBLOCK as a string of at most 256 characters, or
176 #f if SBLOCK has no volume name."
177 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
179 (define (check-btrfs-file-system device)
180 "Return the health of a btrfs file system on DEVICE."
181 (match (status:exit-val
182 (system* "btrfs" "device" "scan"))
188 ;;; FAT32 file systems.
191 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
193 (define-syntax %fat32-endianness
194 ;; Endianness of fat file systems.
195 (identifier-syntax (endianness little)))
197 (define (fat32-superblock? sblock)
198 "Return #t when SBLOCK is a fat32 superblock."
199 (bytevector=? (sub-bytevector sblock 82 8)
200 (string->utf8 "FAT32 ")))
202 (define (read-fat32-superblock device)
203 "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
204 #f if DEVICE does not contain a fat32 file system."
205 (read-superblock device 0 90 fat32-superblock?))
207 (define (fat32-superblock-uuid sblock)
208 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
209 (sub-bytevector sblock 67 4))
211 (define (fat32-uuid->string uuid)
212 "Convert fat32 UUID, a 4-byte bytevector, to its string representation."
213 (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2))
214 (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
215 (format #f "~:@(~x-~x~)" low high)))
217 (define (fat32-superblock-volume-name sblock)
218 "Return the volume name of SBLOCK as a string of at most 11 characters, or
219 #f if SBLOCK has no volume name. The volume name is a latin1 string.
220 Trailing spaces are trimmed."
221 (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
223 (define (check-fat32-file-system device)
224 "Return the health of a fat file system on DEVICE."
225 (match (status:exit-val
226 (system* "fsck.vfat" "-v" "-a" device))
228 (1 'errors-corrected)
233 ;;; ISO9660 file systems.
236 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
238 (define (iso9660-superblock? sblock)
239 "Return #t when SBLOCK is an iso9660 volume descriptor."
240 (bytevector=? (sub-bytevector sblock 1 6)
241 ;; Note: "\x01" is the volume descriptor format version
242 (string->utf8 "CD001\x01")))
244 (define (read-iso9660-primary-volume-descriptor device offset)
245 "Find and read the first primary volume descriptor, starting at OFFSET.
246 Return #f if not found."
247 (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
248 (type-code (if sblock
249 (bytevector-u8-ref sblock 0)
251 "Could not read ISO9660 primary
252 volume descriptor from ~s"
255 (255 #f) ; Volume Descriptor Set Terminator.
256 (1 sblock) ; Primary Volume Descriptor
257 (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
259 (define (read-iso9660-superblock device)
260 "Return the raw contents of DEVICE's iso9660 primary volume descriptor
261 as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
262 ;; Start reading at sector 16.
263 ;; Since we are not sure that the device contains an ISO9660 filesystem,
264 ;; we have to find that out first.
265 (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
266 (read-iso9660-primary-volume-descriptor device (* 2048 16))
267 #f)) ; Device does not contain an iso9660 filesystem.
269 (define (iso9660-superblock-uuid sblock)
270 "Return the modification time of an iso9660 primary volume descriptor
271 SBLOCK as a bytevector. If that's not set, returns the creation time."
272 ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
273 ;; Compare Grub: "2014-12-02-19-30-23-00".
274 ;; Compare blkid result: "2014-12-02-19-30-23-00".
275 ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
276 (let* ((creation-time (sub-bytevector sblock 813 17))
277 (modification-time (sub-bytevector sblock 830 17))
278 (unset-time (make-bytevector 17 0))
279 (time (if (bytevector=? unset-time modification-time)
282 (sub-bytevector time 0 16))) ; strips GMT offset.
284 (define (iso9660-uuid->string uuid)
285 "Given an UUID bytevector, return its timestamp string."
286 (define (digits->string bytes)
287 (latin1->string bytes (lambda (c) #f)))
288 (let* ((year (sub-bytevector uuid 0 4))
289 (month (sub-bytevector uuid 4 2))
290 (day (sub-bytevector uuid 6 2))
291 (hour (sub-bytevector uuid 8 2))
292 (minute (sub-bytevector uuid 10 2))
293 (second (sub-bytevector uuid 12 2))
294 (hundredths (sub-bytevector uuid 14 2))
295 (parts (list year month day hour minute second hundredths)))
296 (string-append (string-join (map digits->string parts)))))
298 (define (iso9660-superblock-volume-name sblock)
299 "Return the volume name of SBLOCK as a string. The volume name is an ASCII
300 string. Trailing spaces are trimmed."
301 ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
302 (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
303 (lambda (c) #f)) #\space))
307 ;;; LUKS encrypted devices.
310 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
311 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
312 ;; version 1.2.1 of this document.
314 (define-syntax %luks-endianness
315 ;; Endianness of LUKS headers.
316 (identifier-syntax (endianness big)))
318 (define (luks-superblock? sblock)
319 "Return #t when SBLOCK is a luks superblock."
321 ;; The 'LUKS_MAGIC' constant.
322 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
324 (let ((magic (sub-bytevector sblock 0 6))
325 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
326 (and (bytevector=? magic %luks-magic)
329 (define (read-luks-header file)
330 "Read a LUKS header from FILE. Return the raw header on success, and #f if
331 not valid header was found."
332 ;; Size in bytes of the LUKS header, including key slots.
333 (read-superblock file 0 592 luks-superblock?))
335 (define (luks-header-uuid header)
336 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
337 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
338 ;; bytes of its ASCII representation.
339 (let ((uuid (sub-bytevector header 168 36)))
340 (string->uuid (utf8->string uuid))))
344 ;;; Partition lookup.
347 (define (disk-partitions)
348 "Return the list of device names corresponding to valid disk partitions."
349 (define (last-character str)
350 (string-ref str (- (string-length str) 1)))
352 (define (partition? name major minor)
353 ;; Select device names that end in a digit, like libblkid's 'probe_all'
354 ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition"
355 ;; doesn't work for partitions coming from mapped devices.
356 (and (char-set-contains? char-set:digit (last-character name))
357 (> major 2))) ;ignore RAM disks and floppy disks
359 (call-with-input-file "/proc/partitions"
361 ;; Skip the two header lines.
365 ;; Read each subsequent line, and extract the last space-separated
367 (let loop ((parts '()))
368 (let ((line (read-line port)))
369 (if (eof-object? line)
371 (match (string-tokenize line)
372 (((= string->number major) (= string->number minor)
374 (if (partition? name major minor)
375 (loop (cons name parts))
376 (loop parts))))))))))
378 (define (ENOENT-safe proc)
379 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
380 warning and #f as the result."
386 ;; When running on the hand-made /dev,
387 ;; 'disk-partitions' could return partitions for which
388 ;; we have no /dev node. Handle that gracefully.
389 (let ((errno (system-error-errno args)))
390 (cond ((= ENOENT errno)
391 (format (current-error-port)
392 "warning: device '~a' not found~%" device)
394 ((= ENOMEDIUM errno) ;for removable media
397 (apply throw args))))))))
399 (define (partition-field-reader read field)
400 "Return a procedure that takes a device and returns the value of a FIELD in
401 the partition superblock or #f."
402 (let ((read (ENOENT-safe read)))
404 (let ((sblock (read device)))
408 (define (read-partition-field device partition-field-readers)
409 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
410 takes a list of PARTITION-FIELD-READERS and returns the result of the first
411 partition field reader that returned a value."
412 (match (filter-map (cut apply <> (list device)) partition-field-readers)
416 (define %partition-label-readers
417 (list (partition-field-reader read-iso9660-superblock
418 iso9660-superblock-volume-name)
419 (partition-field-reader read-ext2-superblock
420 ext2-superblock-volume-name)
421 (partition-field-reader read-btrfs-superblock
422 btrfs-superblock-volume-name)
423 (partition-field-reader read-fat32-superblock
424 fat32-superblock-volume-name)))
426 (define %partition-uuid-readers
427 (list (partition-field-reader read-iso9660-superblock
428 iso9660-superblock-uuid)
429 (partition-field-reader read-ext2-superblock
430 ext2-superblock-uuid)
431 (partition-field-reader read-btrfs-superblock
432 btrfs-superblock-uuid)
433 (partition-field-reader read-fat32-superblock
434 fat32-superblock-uuid)))
436 (define read-partition-label
437 (cut read-partition-field <> %partition-label-readers))
439 (define read-partition-uuid
440 (cut read-partition-field <> %partition-uuid-readers))
442 (define (partition-predicate reader =)
443 "Return a predicate that returns true if the FIELD of partition header that
444 was READ is = to the given value."
447 (let ((actual (reader device)))
449 (= actual expected))))))
451 (define partition-label-predicate
452 (partition-predicate read-partition-label string=?))
454 (define partition-uuid-predicate
455 (partition-predicate read-partition-uuid bytevector=?))
457 (define luks-partition-uuid-predicate
459 (partition-field-reader read-luks-header luks-header-uuid)
462 (define (find-partition predicate)
463 "Return the first partition found that matches PREDICATE, or #f if none
466 (find (predicate expected)
467 (map (cut string-append "/dev/" <>)
468 (disk-partitions)))))
470 (define find-partition-by-label
471 (find-partition partition-label-predicate))
473 (define find-partition-by-uuid
474 (find-partition partition-uuid-predicate))
476 (define find-partition-by-luks-uuid
477 (find-partition luks-partition-uuid-predicate))
484 (define-syntax %network-byte-order
485 (identifier-syntax (endianness big)))
487 (define (uuid->string uuid)
488 "Convert UUID, a 16-byte bytevector, to its string representation, something
489 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
490 ;; See <https://tools.ietf.org/html/rfc4122>.
491 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
492 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
493 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
494 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
495 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
496 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
497 time-low time-mid time-hi clock-seq node)))
500 ;; The regexp of a UUID.
501 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
503 (define (string->uuid str)
504 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
505 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
506 UUID representation."
507 (and=> (regexp-exec %uuid-rx str)
509 (letrec-syntax ((hex->number
512 (string->number (match:substring match index)
516 ((_ bv index (number len) rest ...)
518 (bytevector-uint-set! bv index number
519 (endianness big) len)
520 (put! bv (+ index len) rest ...)))
523 (let ((time-low (hex->number 1))
524 (time-mid (hex->number 2))
525 (time-hi (hex->number 3))
526 (clock-seq (hex->number 4))
527 (node (hex->number 5))
528 (uuid (make-bytevector 16)))
530 (time-low 4) (time-mid 2) (time-hi 2)
531 (clock-seq 2) (node 6)))))))
534 (define* (canonicalize-device-spec spec #:optional (title 'any))
535 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
538 • 'device', in which case SPEC is known to designate a device node--e.g.,
540 • 'label', in which case SPEC is known to designate a partition label--e.g.,
542 • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
543 designating a partition;
544 • 'any', in which case SPEC can be anything.
547 ;; Number of times we retry partition label resolution, 1 second per
548 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
549 ;; USB key would be detected by the kernel, so we must wait for at least
553 (define canonical-title
554 ;; The realm of canonicalization.
557 ;; The "--root=SPEC" kernel command-line option always provides a
558 ;; string, but the string can represent a device, a UUID, or a
559 ;; label. So check for all three.
560 (cond ((string-prefix? "/" spec) 'device)
561 ((string->uuid spec) 'uuid)
566 (define (resolve find-partition spec fmt)
567 (let loop ((count 0))
568 (let ((device (find-partition spec)))
570 ;; Some devices take a bit of time to appear, most notably USB
571 ;; storage devices. Thus, wait for the device to appear.
572 (if (> count max-trials)
573 (error "failed to resolve partition" (fmt spec))
575 (format #t "waiting for partition '~a' to appear...~%"
578 (loop (+ 1 count))))))))
580 (case canonical-title
585 ;; Resolve the label.
586 (resolve find-partition-by-label spec identity))
588 (resolve find-partition-by-uuid
594 (error "unknown device title" title))))
596 (define (check-file-system device type)
597 "Run a file system check of TYPE on DEVICE."
598 (define check-procedure
600 ((string-prefix? "ext" type) check-ext2-file-system)
601 ((string-prefix? "btrfs" type) check-btrfs-file-system)
602 ((string-suffix? "fat" type) check-fat32-file-system)
606 (match (check-procedure device)
610 (format (current-error-port)
611 "File system check corrected errors on ~a; continuing~%"
614 (format (current-error-port)
615 "File system check corrected errors on ~a; rebooting~%"
620 (format (current-error-port)
621 "File system check on ~a failed; spawning Bourne-like REPL~%"
623 (start-repl %bournish-language)))
624 (format (current-error-port)
625 "No file system check procedure for ~a; skipping~%"
628 (define (mount-flags->bit-mask flags)
629 "Return the number suitable for the 'flags' argument of 'mount' that
630 corresponds to the symbols listed in FLAGS."
631 (let loop ((flags flags))
633 (('read-only rest ...)
634 (logior MS_RDONLY (loop rest)))
635 (('bind-mount rest ...)
636 (logior MS_BIND (loop rest)))
638 (logior MS_NOSUID (loop rest)))
640 (logior MS_NODEV (loop rest)))
642 (logior MS_NOEXEC (loop rest)))
646 (define* (mount-file-system spec #:key (root "/root"))
647 "Mount the file system described by SPEC under ROOT. SPEC must have the
650 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
652 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
653 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
654 run a file system check."
656 (define (mount-nfs source mount-point type flags options)
657 (let* ((idx (string-rindex source #\:))
658 (host-part (string-take source idx))
659 ;; Strip [] from around host if present
660 (host (match (string-split host-part (string->char-set "[]"))
663 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
664 (sa (addrinfo:addr aa))
665 (inet-addr (inet-ntop (sockaddr:fam sa)
666 (sockaddr:addr sa))))
668 ;; Mounting an NFS file system requires passing the address
669 ;; of the server in the addr= option
670 (mount source mount-point type flags
671 (string-append "addr="
674 (string-append "," options)
677 ((source title mount-point type (flags ...) options check?)
678 (let ((source (canonicalize-device-spec source title))
679 (mount-point (string-append root "/" mount-point))
680 (flags (mount-flags->bit-mask flags)))
682 (check-file-system source type))
684 ;; Create the mount point. Most of the time this is a directory, but
685 ;; in the case of a bind mount, a regular file or socket may be needed.
686 (if (and (= MS_BIND (logand flags MS_BIND))
687 (not (file-is-directory? source)))
688 (unless (file-exists? mount-point)
689 (mkdir-p (dirname mount-point))
690 (call-with-output-file mount-point (const #t)))
691 (mkdir-p mount-point))
694 ((string-prefix? "nfs" type)
695 (mount-nfs source mount-point type flags options))
697 (mount source mount-point type flags options)))
699 ;; For read-only bind mounts, an extra remount is needed, as per
700 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
701 (when (and (= MS_BIND (logand flags MS_BIND))
702 (= MS_RDONLY (logand flags MS_RDONLY)))
703 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
704 (mount source mount-point type flags #f)))))))
706 ;;; file-systems.scm ends here