guix/gnu/build/file-systems.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build file-systems)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (guix build utils)
  #:use-module (guix build bournish)
  #:use-module ((guix build syscalls)
                #:hide (file-system-type))
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (system foreign)
  #:autoload   (system repl repl) (start-repl)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (disk-partitions
            partition-label-predicate
            partition-uuid-predicate
            partition-luks-uuid-predicate
            find-partition-by-label
            find-partition-by-uuid
            find-partition-by-luks-uuid
            canonicalize-device-spec

            read-partition-label
            read-partition-uuid
            read-luks-partition-uuid

            bind-mount

            mount-flags->bit-mask
            check-file-system
            mount-file-system))

;;; Commentary:
;;;
;;; This modules provides tools to deal with disk partitions, and to mount and
;;; check file systems.
;;;
;;; Code:

(define (bind-mount source target)
  "Bind-mount SOURCE at TARGET."
  (mount source target "" MS_BIND))

(define (seek* fd/port offset whence)
  "Like 'seek' but return -1 instead of throwing to 'system-error' upon
EINVAL.  This makes it easier to catch cases like OFFSET being too large for
FD/PORT."
  (catch 'system-error
    (lambda ()
      (seek fd/port offset whence))
    (lambda args
      (if (= EINVAL (system-error-errno args))
          -1
          (apply throw args)))))

(define (read-superblock device offset size magic?)
  "Read a superblock of SIZE from OFFSET and DEVICE.  Return the raw
superblock on success, and #f if no valid superblock was found.  MAGIC?
takes a bytevector and returns #t when it's a valid superblock."
  (call-with-input-file device
    (lambda (port)
      (and (= offset (seek* port offset SEEK_SET))
           (let ((block (make-bytevector size)))
             (match (get-bytevector-n! port block 0 (bytevector-length block))
               ((? eof-object?)
                #f)
               ((? number? len)
                (and (= len (bytevector-length block))
                     (and (magic? block)
                          block)))))))))

(define null-terminated-latin1->string
  (cut latin1->string <> zero?))

(define (bytevector-utf16-length bv)
  "Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
determine where the NUL terminator is and return its index.  If there's no
NUL terminator, return the size of the bytevector."
  (let ((length (bytevector-length bv)))
    (let loop ((index 0))
      (if (< index length)
          (if (zero? (bytevector-u16-ref bv index 'little))
              index
              (loop (+ index 2)))
          length))))

(define* (bytevector->u16-list bv endianness #:optional (index 0))
  (if (< index (bytevector-length bv))
      (cons (bytevector-u16-ref bv index endianness)
            (bytevector->u16-list bv endianness (+ index 2)))
      '()))

;; The initrd doesn't have iconv data, so do the conversion ourselves.
(define (utf16->string bv endianness)
  (list->string
   (map integer->char
        (reverse
         (let loop ((remainder (bytevector->u16-list bv endianness))
                    (result '()))
             (match remainder
              (() result)
              ((a) (cons a result))
              ((a b x ...)
               (if (and (>= a #xD800) (< a #xDC00) ; high surrogate
                        (>= b #xDC00) (< b #xE000)) ; low surrogate
                   (loop x (cons (+ #x10000
                                    (* #x400 (- a #xD800))
                                    (- b #xDC00))
                                 result))
                   (loop (cons b x) (cons a result))))))))))

(define (null-terminated-utf16->string bv endianness)
  (utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
                 endianness))


;;;
;;; Ext2 file systems.
;;;

;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
;; TODO: Use "packed structs" from Guile-OpenGL or similar.

(define-syntax %ext2-endianness
  ;; Endianness of ext2 file systems.
  (identifier-syntax (endianness little)))

(define (ext2-superblock? sblock)
  "Return #t when SBLOCK is an ext2 superblock."
  (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
    (= magic #xef53)))

(define (read-ext2-superblock device)
  "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
if DEVICE does not contain an ext2 file system."
  (read-superblock device 1024 264 ext2-superblock?))

(define (ext2-superblock-uuid sblock)
  "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 104 16))

(define (ext2-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 120 16)))

(define (check-ext2-file-system device)
  "Return the health of an ext2 file system on DEVICE."
  (match (status:exit-val
          (system* "e2fsck" "-v" "-p" "-C" "0" device))
    (0 'pass)
    (1 'errors-corrected)
    (2 'reboot-required)
    (_ 'fatal-error)))


;;;
;;; Linux swap.
;;;

;; Linux "swap space" is not a file system but it has a UUID and volume name,
;; like actual file systems, and we want to be able to look up swap partitions
;; by UUID and by label.

(define %linux-swap-magic
  (string->utf8 "SWAPSPACE2"))

;; Like 'PAGE_SIZE' in Linux, arch/x86/include/asm/page.h.
;; XXX: This is always 4K on x86_64, i386, and ARMv7.  However, on AArch64,
;; this is determined by 'CONFIG_ARM64_PAGE_SHIFT' in the kernel, which is 12
;; by default (4K) but can be 14 or 16.
(define %page-size 4096)

(define (linux-swap-superblock? sblock)
  "Return #t when SBLOCK is an linux-swap superblock."
  (and (= (bytevector-length sblock) %page-size)
       (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
                     %linux-swap-magic)))

(define (read-linux-swap-superblock device)
  "Return the raw contents of DEVICE's linux-swap superblock as a bytevector, or #f
if DEVICE does not contain an linux-swap file system."
  (read-superblock device 0 %page-size linux-swap-superblock?))

;; See 'union swap_header' in 'include/linux/swap.h'.

(define (linux-swap-superblock-uuid sblock)
  "Return the UUID of Linux-swap superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock (+ 1024 4 4 4) 16))

(define (linux-swap-superblock-volume-name sblock)
  "Return the label of Linux-swap superblock SBLOCK as a string."
  (null-terminated-latin1->string
   (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))


;;;
;;; Bcachefs file systems.
;;;

;; <https://evilpiepirate.org/git/bcachefs-tools.git/tree/libbcachefs/bcachefs_format.h>

(define-syntax %bcachefs-endianness
  ;; Endianness of bcachefs file systems.
  (identifier-syntax (endianness little)))

(define (bcachefs-superblock? sblock)
  "Return #t when SBLOCK is an bcachefs superblock."
  (bytevector=? (sub-bytevector sblock 24 16)
                #vu8(#xc6 #x85 #x73 #xf6 #x4e #x1a #x45 #xca
                     #x82 #x65 #xf5 #x7f #x48 #xba #x6d #x81)))

(define (read-bcachefs-superblock device)
  "Return the raw contents of DEVICE's bcachefs superblock as a bytevector, or #f
if DEVICE does not contain a bcachefs file system."
  ;; We completely ignore the back-up superblock & any checksum errors.
  ;; Superblock field names, with offset & length respectively, in bytes:
  ;;  0 16 bch_csum
  ;; 16  8 version
  ;; 24 16 magic
  ;; 40 16 uuid ← ‘internal UUID’, you probably don't want this
  ;; 56 16 user_uuid ← ‘external UUID’, the one by which to mount
  ;; 72 32 label
  ;; … there are more & the superblock is extensible, but we don't care yet.
  (read-superblock device 4096 104 bcachefs-superblock?))

(define (bcachefs-superblock-external-uuid sblock)
  "Return the external UUID of bcachefs superblock SBLOCK as a 16-byte
bytevector."
  (sub-bytevector sblock 56 16))

(define (bcachefs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 32 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 72 32)))

(define (check-bcachefs-file-system device)
  "Return the health of a bcachefs file system on DEVICE."
  (let ((ignored-bits (logior 2))       ; DEVICE was mounted read-only
        (status
         (status:exit-val
          (apply system* "bcachefs" "fsck" "-p" "-v"
                 ;; Make each multi-device member a separate argument.
                 (string-split device #\:)))))
    (match (logand (lognot ignored-bits) status)
      (0 'pass)
      (1 'errors-corrected)
      (_ 'fatal-error))))


;;;
;;; Btrfs file systems.
;;;

;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.

(define-syntax %btrfs-endianness
  ;; Endianness of btrfs file systems.
  (identifier-syntax (endianness little)))

(define (btrfs-superblock? sblock)
  "Return #t when SBLOCK is a btrfs superblock."
  (bytevector=? (sub-bytevector sblock 64 8)
                (string->utf8 "_BHRfS_M")))

(define (read-btrfs-superblock device)
  "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
if DEVICE does not contain a btrfs file system."
  (read-superblock device 65536 4096 btrfs-superblock?))

(define (btrfs-superblock-uuid sblock)
  "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 32 16))

(define (btrfs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 256 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 299 256)))

(define (check-btrfs-file-system device)
  "Return the health of a btrfs file system on DEVICE."
  (match (status:exit-val
          (system* "btrfs" "device" "scan"))
    (0 'pass)
    (_ 'fatal-error)))


;;;
;;; FAT32 file systems.
;;;

;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.

(define (fat32-superblock? sblock)
  "Return #t when SBLOCK is a fat32 superblock."
  (bytevector=? (sub-bytevector sblock 82 8)
                (string->utf8 "FAT32   ")))

(define (read-fat32-superblock device)
  "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
#f if DEVICE does not contain a fat32 file system."
  (read-superblock device 0 90 fat32-superblock?))

(define (fat32-superblock-uuid sblock)
  "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
  (sub-bytevector sblock 67 4))

(define (fat32-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 11 characters, or
#f if SBLOCK has no volume name.  The volume name is a latin1 string.
Trailing spaces are trimmed."
  (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))

(define (check-fat-file-system device)
  "Return the health of a fat file system on DEVICE."
  (match (status:exit-val
          (system* "fsck.vfat" "-v" "-a" device))
    (0 'pass)
    (1 'errors-corrected)
    (_ 'fatal-error)))


;;;
;;; FAT16 file systems.
;;;

(define (fat16-superblock? sblock)
  "Return #t when SBLOCK is a fat16 boot record."
  (bytevector=? (sub-bytevector sblock 54 8)
                (string->utf8 "FAT16   ")))

(define (read-fat16-superblock device)
  "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
#f if DEVICE does not contain a fat16 file system."
  (read-superblock device 0 62 fat16-superblock?))

(define (fat16-superblock-uuid sblock)
  "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
  (sub-bytevector sblock 39 4))

(define (fat16-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 11 characters, or
#f if SBLOCK has no volume name.  The volume name is a latin1 string.
Trailing spaces are trimmed."
  (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
                                     (lambda (c) #f))
                     #\space))


;;;
;;; ISO9660 file systems.
;;;

;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.

(define (iso9660-superblock? sblock)
  "Return #t when SBLOCK is an iso9660 volume descriptor."
  (bytevector=? (sub-bytevector sblock 1 6)
                ;; Note: "\x01" is the volume descriptor format version
                (string->utf8 "CD001\x01")))

(define (read-iso9660-primary-volume-descriptor device offset)
  "Find and read the first primary volume descriptor, starting at OFFSET.
   Return #f if not found."
  (let* ((sblock    (read-superblock device offset 2048 iso9660-superblock?))
         (type-code (if sblock
                        (bytevector-u8-ref sblock 0)
                        (error (format #f
                                       "Could not read ISO9660 primary
volume descriptor from ~s"
                                       device)))))
    (match type-code
      (255 #f) ; Volume Descriptor Set Terminator.
      (1 sblock) ; Primary Volume Descriptor
      (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))

(define (read-iso9660-superblock device)
  "Return the raw contents of DEVICE's iso9660 primary volume descriptor
as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
  ;; Start reading at sector 16.
  ;; Since we are not sure that the device contains an ISO9660 file system,
  ;; we have to find that out first.
  (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
      (read-iso9660-primary-volume-descriptor device (* 2048 16))
      #f)) ; Device does not contain an iso9660 file system.

(define (iso9660-superblock-uuid sblock)
  "Return the modification time of an iso9660 primary volume descriptor
SBLOCK as a bytevector.  If that's not set, returns the creation time."
  ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
  ;; Compare Grub: "2014-12-02-19-30-23-00".
  ;; Compare blkid result: "2014-12-02-19-30-23-00".
  ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
  (let* ((creation-time (sub-bytevector sblock 813 17))
         (modification-time (sub-bytevector sblock 830 17))
         (unset-time (make-bytevector 17 0))
         (time (if (bytevector=? unset-time modification-time)
                   creation-time
                   modification-time)))
    (sub-bytevector time 0 16))) ; strips GMT offset.

(define (iso9660-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
string.  Trailing spaces are trimmed."
  ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
  (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
                                     (lambda (c) #f)) #\space))


;;;
;;; JFS file systems.
;;;

;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.

(define-syntax %jfs-endianness
  ;; Endianness of JFS file systems.
  (identifier-syntax (endianness little)))

(define (jfs-superblock? sblock)
  "Return #t when SBLOCK is a JFS superblock."
  (bytevector=? (sub-bytevector sblock 0 4)
                (string->utf8 "JFS1")))

(define (read-jfs-superblock device)
  "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
if DEVICE does not contain a JFS file system."
  (read-superblock device 32768 184 jfs-superblock?))

(define (jfs-superblock-uuid sblock)
  "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock 136 16))

(define (jfs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 16 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-latin1->string (sub-bytevector sblock 152 16)))

(define (check-jfs-file-system device)
  "Return the health of a JFS file system on DEVICE."
  (match (status:exit-val
          (system* "jfs_fsck" "-p" "-v" device))
    (0 'pass)
    (1 'errors-corrected)
    (2 'reboot-required)
    (_ 'fatal-error)))


;;;
;;; F2FS (Flash-Friendly File System)
;;;

;;; https://git.kernel.org/pub/scm/linux/kernel/git/jaegeuk/f2fs.git/tree/include/linux/f2fs_fs.h
;;; (but using xxd proved to be simpler)

(define-syntax %f2fs-endianness
  ;; Endianness of F2FS file systems
  (identifier-syntax (endianness little)))

;; F2FS actually stores two adjacent copies of the superblock.
;; should we read both?
(define (f2fs-superblock? sblock)
  "Return #t when SBLOCK is an F2FS superblock."
  (let ((magic (bytevector-u32-ref sblock 0 %f2fs-endianness)))
    (= magic #xF2F52010)))

(define (read-f2fs-superblock device)
  "Return the raw contents of DEVICE's F2FS superblock as a bytevector, or #f
if DEVICE does not contain an F2FS file system."
  (read-superblock device
                   ;; offset of magic in first copy
                   #x400
                   ;; difference between magic of second
                   ;; and first copies
                   (- #x1400 #x400)
                   f2fs-superblock?))

(define (f2fs-superblock-uuid sblock)
  "Return the UUID of F2FS superblock SBLOCK as a 16-byte bytevector."
  (sub-bytevector sblock
                  (- (+ #x460 12)
                     ;; subtract superblock offset
                     #x400)
                  16))

(define (f2fs-superblock-volume-name sblock)
  "Return the volume name of SBLOCK as a string of at most 512 characters, or
#f if SBLOCK has no volume name."
  (null-terminated-utf16->string
   (sub-bytevector sblock (- (+ #x470 12) #x400) 512)
   %f2fs-endianness))

(define (check-f2fs-file-system device)
  "Return the health of a F2FS file system on DEVICE."
  (match (status:exit-val
          (system* "fsck.f2fs" "-p" device))
    ;; 0 and -1 are the only two possibilities
    ;; (according to the manpage)
    (0 'pass)
    (_ 'fatal-error)))


;;;
;;; LUKS encrypted devices.
;;;

;; The LUKS header format is described in "LUKS On-Disk Format Specification":
;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>.  We follow
;; version 1.2.1 of this document.

;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
;; It is a WIP document.

(define-syntax %luks-endianness
  ;; Endianness of LUKS headers.
  (identifier-syntax (endianness big)))

(define (luks-superblock? sblock)
  "Return #t when SBLOCK is a luks superblock."
  (define %luks-magic
    ;; The 'LUKS_MAGIC' constant.
    (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
                                 (list #xba #xbe))))
  (let ((magic   (sub-bytevector sblock 0 6))
        (version (bytevector-u16-ref sblock 6 %luks-endianness)))
    (and (bytevector=? magic %luks-magic)
         (or (= version 1) (= version 2)))))

(define (read-luks-header file)
  "Read a LUKS header from FILE.  Return the raw header on success, and #f if
not valid header was found."
  ;; Size in bytes of the LUKS binary header, which includes key slots in
  ;; LUKS1.  In LUKS2 the binary header is partially backward compatible, so
  ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
  ;; not part of this header in LUKS2, but are included in the JSON metadata
  ;; area that follows.
  (read-superblock file 0 592 luks-superblock?))

(define (luks-header-uuid header)
  "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
  ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
  ;; bytes of its ASCII representation.
  (let ((uuid (sub-bytevector header 168 36)))
    (string->uuid (utf8->string uuid))))


;;;
;;; NTFS file systems.
;;;

;; Taken from <linux-libre>/fs/ntfs/layout.h

(define-syntax %ntfs-endianness
  ;; Endianness of NTFS file systems.
  (identifier-syntax (endianness little)))

(define (ntfs-superblock? sblock)
  "Return #t when SBLOCK is a NTFS superblock."
  (bytevector=? (sub-bytevector sblock 3 8)
                (string->utf8 "NTFS    ")))

(define (read-ntfs-superblock device)
  "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f
if DEVICE does not contain a NTFS file system."
  (read-superblock device 0 511 ntfs-superblock?))

(define (ntfs-superblock-uuid sblock)
  "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector."
  (sub-bytevector sblock 72 8))

;; TODO: Add ntfs-superblock-volume-name.  The partition label is not stored
;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
;; way harder to access.

(define (check-ntfs-file-system device)
  "Return the health of a NTFS file system on DEVICE."
  (match (status:exit-val
          (system* "ntfsfix" device))
    (0 'pass)
    (_ 'fatal-error)))


;;;
;;; Partition lookup.
;;;

(define (disk-partitions)
  "Return the list of device names corresponding to valid disk partitions."
  (define (partition? name major minor)
    ;; grub-mkrescue does some funny things for EFI support which
    ;; makes it a lot more difficult than one would expect to support
    ;; booting an ISO-9660 image from an USB flash drive.
    ;; For example there's a buggy (too small) hidden partition in it
    ;; which Linux mounts and then proceeds to fail while trying to
    ;; fall off the edge.
    ;; In any case, partition tables are supposed to be optional so
    ;; here we allow checking entire disks for file systems, too.
    (> major 2))                      ;ignore RAM disks and floppy disks

  (call-with-input-file "/proc/partitions"
    (lambda (port)
      ;; Skip the two header lines.
      (read-line port)
      (read-line port)

      ;; Read each subsequent line, and extract the last space-separated
      ;; field.
      (let loop ((parts '()))
        (let ((line  (read-line port)))
          (if (eof-object? line)
              (reverse parts)
              (match (string-tokenize line)
                (((= string->number major) (= string->number minor)
                  blocks name)
                 (if (partition? name major minor)
                     (loop (cons name parts))
                     (loop parts))))))))))

(define (ENOENT-safe proc)
  "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
warning and #f as the result."
  (lambda (device)
    (catch 'system-error
      (lambda ()
        (proc device))
      (lambda args
        ;; When running on the hand-made /dev,
        ;; 'disk-partitions' could return partitions for which
        ;; we have no /dev node.  Handle that gracefully.
        (let ((errno (system-error-errno args)))
          (cond ((= ENOENT errno)
                 (format (current-error-port)
                         "warning: device '~a' not found~%" device)
                 #f)
                ((= ENOMEDIUM errno)              ;for removable media
                 #f)
                ((= EIO errno)                    ;unreadable hardware like audio CDs
                 (format (current-error-port)
                         "warning: failed to read from device '~a'~%" device)
                 #f)
                (else
                 (apply throw args))))))))

(define (partition-field-reader read field)
  "Return a procedure that takes a device and returns the value of a FIELD in
the partition superblock or #f."
  (let ((read (ENOENT-safe read)))
    (lambda (device)
      (let ((sblock (read device)))
        (and sblock
             (field sblock))))))

(define (read-partition-field device partition-field-readers)
  "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
takes a list of PARTITION-FIELD-READERS and returns the result of the first
partition field reader that returned a value."
  (match (filter-map (cut apply <> (list device)) partition-field-readers)
    ((field . _) field)
    (_ #f)))

(define %partition-label-readers
  (list (partition-field-reader read-iso9660-superblock
                                iso9660-superblock-volume-name)
        (partition-field-reader read-ext2-superblock
                                ext2-superblock-volume-name)
        (partition-field-reader read-linux-swap-superblock
                                linux-swap-superblock-volume-name)
        (partition-field-reader read-bcachefs-superblock
                                bcachefs-superblock-volume-name)
        (partition-field-reader read-btrfs-superblock
                                btrfs-superblock-volume-name)
        (partition-field-reader read-fat32-superblock
                                fat32-superblock-volume-name)
        (partition-field-reader read-fat16-superblock
                                fat16-superblock-volume-name)
        (partition-field-reader read-jfs-superblock
                                jfs-superblock-volume-name)
        (partition-field-reader read-f2fs-superblock
                                f2fs-superblock-volume-name)))

(define %partition-uuid-readers
  (list (partition-field-reader read-iso9660-superblock
                                iso9660-superblock-uuid)
        (partition-field-reader read-ext2-superblock
                                ext2-superblock-uuid)
        (partition-field-reader read-linux-swap-superblock
                                linux-swap-superblock-uuid)
        (partition-field-reader read-bcachefs-superblock
                                bcachefs-superblock-external-uuid)
        (partition-field-reader read-btrfs-superblock
                                btrfs-superblock-uuid)
        (partition-field-reader read-fat32-superblock
                                fat32-superblock-uuid)
        (partition-field-reader read-fat16-superblock
                                fat16-superblock-uuid)
        (partition-field-reader read-jfs-superblock
                                jfs-superblock-uuid)
        (partition-field-reader read-f2fs-superblock
                                f2fs-superblock-uuid)
        (partition-field-reader read-ntfs-superblock
                                ntfs-superblock-uuid)))

(define read-partition-label
  (cut read-partition-field <> %partition-label-readers))

(define read-partition-uuid
  (cut read-partition-field <> %partition-uuid-readers))

(define luks-partition-field-reader
  (partition-field-reader read-luks-header luks-header-uuid))

(define read-luks-partition-uuid
  (cut read-partition-field <> (list luks-partition-field-reader)))

(define (partition-predicate reader =)
  "Return a predicate that returns true if the FIELD of partition header that
was READ is = to the given value."
  (lambda (expected)
    (lambda (device)
      (let ((actual (reader device)))
        (and actual
             (= actual expected))))))

(define partition-label-predicate
  (partition-predicate read-partition-label string=?))

(define partition-uuid-predicate
  (partition-predicate read-partition-uuid uuid=?))

(define luks-partition-uuid-predicate
  (partition-predicate luks-partition-field-reader uuid=?))

(define (find-partition predicate)
  "Return the first partition found that matches PREDICATE, or #f if none
were found."
  (lambda (expected)
    (find (predicate expected)
          (map (cut string-append "/dev/" <>)
               (disk-partitions)))))

(define find-partition-by-label
  (find-partition partition-label-predicate))

(define find-partition-by-uuid
  (find-partition partition-uuid-predicate))

(define find-partition-by-luks-uuid
  (find-partition luks-partition-uuid-predicate))


(define (canonicalize-device-spec spec)
  "Return the device name corresponding to SPEC, which can be a <uuid>, a
<file-system-label>, or a string (typically a /dev file name or an nfs-root
containing ':/')."
  (define max-trials
    ;; Number of times we retry partition label resolution, 1 second per
    ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
    ;; USB key would be detected by the kernel, so we must wait for at least
    ;; this long.
    20)

  (define (resolve find-partition spec fmt)
    (let loop ((count 0))
      (let ((device (find-partition spec)))
        (or device
            ;; Some devices take a bit of time to appear, most notably USB
            ;; storage devices.  Thus, wait for the device to appear.
            (if (> count max-trials)
                (error "failed to resolve partition" (fmt spec))
                (begin
                  (format #t "waiting for partition '~a' to appear...~%"
                          (fmt spec))
                  (sleep 1)
                  (loop (+ 1 count))))))))

  (match spec
    ((? string?)
     (if (string-contains spec ":/")
         spec                  ; do not resolve NFS devices
         ;; Nothing to do, but wait until SPEC shows up.
         (resolve identity spec identity)))
    ((? file-system-label?)
     ;; Resolve the label.
     (resolve find-partition-by-label
              (file-system-label->string spec)
              identity))
    ((? uuid?)
     (resolve find-partition-by-uuid
              (uuid-bytevector spec)
              uuid->string))))

(define (check-file-system device type)
  "Run a file system check of TYPE on DEVICE."
  (define check-procedure
    (cond
     ((string-prefix? "ext" type) check-ext2-file-system)
     ((string-prefix? "bcachefs" type) check-bcachefs-file-system)
     ((string-prefix? "btrfs" type) check-btrfs-file-system)
     ((string-suffix? "fat" type) check-fat-file-system)
     ((string-prefix? "jfs" type) check-jfs-file-system)
     ((string-prefix? "f2fs" type) check-f2fs-file-system)
     ((string-prefix? "ntfs" type) check-ntfs-file-system)
     ((string-prefix? "nfs" type) (const 'pass))
     (else #f)))

  (if check-procedure
      (match (check-procedure device)
        ('pass
         #t)
        ('errors-corrected
         (format (current-error-port)
                 "File system check corrected errors on ~a; continuing~%"
                 device))
        ('reboot-required
         (format (current-error-port)
                 "File system check corrected errors on ~a; rebooting~%"
                 device)
         (sleep 3)
         (reboot))
        ('fatal-error
         (format (current-error-port) "File system check on ~a failed~%"
                 device)

         ;; Spawn a REPL only if someone would be able to interact with it.
         (when (isatty? (current-input-port))
           (format (current-error-port) "Spawning Bourne-like REPL.~%")

           ;; 'current-output-port' is typically connected to /dev/klog (in
           ;; PID 1), but here we want to make sure we talk directly to the
           ;; user.
           (with-output-to-file "/dev/console"
             (lambda ()
               (start-repl %bournish-language))))))
      (format (current-error-port)
              "No file system check procedure for ~a; skipping~%"
              device)))

(define (mount-flags->bit-mask flags)
  "Return the number suitable for the 'flags' argument of 'mount' that
corresponds to the symbols listed in FLAGS."
  (let loop ((flags flags))
    (match flags
      (('read-only rest ...)
       (logior MS_RDONLY (loop rest)))
      (('bind-mount rest ...)
       (logior MS_BIND (loop rest)))
      (('no-suid rest ...)
       (logior MS_NOSUID (loop rest)))
      (('no-dev rest ...)
       (logior MS_NODEV (loop rest)))
      (('no-exec rest ...)
       (logior MS_NOEXEC (loop rest)))
      (('no-atime rest ...)
       (logior MS_NOATIME (loop rest)))
      (('strict-atime rest ...)
       (logior MS_STRICTATIME (loop rest)))
      (('lazy-time rest ...)
       (logior MS_LAZYTIME (loop rest)))
      (()
       0))))

(define* (mount-file-system fs #:key (root "/root"))
  "Mount the file system described by FS, a <file-system> object, under ROOT."

  (define (mount-nfs source mount-point type flags options)
    (let* ((idx (string-rindex source #\:))
           (host-part (string-take source idx))
           ;; Strip [] from around host if present
           (host (match (string-split host-part (string->char-set "[]"))
                 (("" h "") h)
                 ((h) h)))
           (aa (match (getaddrinfo host "nfs") ((x . _) x)))
           (sa (addrinfo:addr aa))
           (inet-addr (inet-ntop (sockaddr:fam sa)
                                 (sockaddr:addr sa))))

      ;; Mounting an NFS file system requires passing the address
      ;; of the server in the addr= option
      (mount source mount-point type flags
             (string-append "addr="
                            inet-addr
                            (if options
                                (string-append "," options)
                                "")))))
  (let ((type        (file-system-type fs))
        (options     (file-system-options fs))
        (source      (canonicalize-device-spec (file-system-device fs)))
        (mount-point (string-append root "/"
                                    (file-system-mount-point fs)))
        (flags       (mount-flags->bit-mask (file-system-flags fs))))
    (when (file-system-check? fs)
      (check-file-system source type))

    (catch 'system-error
      (lambda ()
        ;; Create the mount point.  Most of the time this is a directory, but
        ;; in the case of a bind mount, a regular file or socket may be
        ;; needed.
        (if (and (= MS_BIND (logand flags MS_BIND))
                 (not (file-is-directory? source)))
            (unless (file-exists? mount-point)
              (mkdir-p (dirname mount-point))
              (call-with-output-file mount-point (const #t)))
            (mkdir-p mount-point))

        (cond
         ((string-prefix? "nfs" type)
          (mount-nfs source mount-point type flags options))
         (else
          (mount source mount-point type flags options)))

        ;; For read-only bind mounts, an extra remount is needed, as per
        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
        ;; 4.0.
        (when (and (= MS_BIND (logand flags MS_BIND))
                   (= MS_RDONLY (logand flags MS_RDONLY)))
          (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
            (mount source mount-point type flags #f))))
      (lambda args
        (or (file-system-mount-may-fail? fs)
            (apply throw args))))))

;;; file-systems.scm ends here