;;; Copyright © 2014, 2015, 2016, 2017, 2018 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 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.
;;;
find-partition-by-luks-uuid
canonicalize-device-spec
+ read-partition-label
+ read-partition-uuid
+ read-luks-partition-uuid
+
bind-mount
mount-flags->bit-mask
(lambda (c) #f)) #\space))
\f
+;;;
+;;; 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)))
+
+\f
;;;
;;; LUKS encrypted devices.
;;;
;; <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)))
(let ((magic (sub-bytevector sblock 0 6))
(version (bytevector-u16-ref sblock 6 %luks-endianness)))
(and (bytevector=? magic %luks-magic)
- (= version 1))))
+ (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 header, including key slots.
+ ;; 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)
(partition-field-reader read-fat32-superblock
fat32-superblock-volume-name)
(partition-field-reader read-fat16-superblock
- fat16-superblock-volume-name)))
+ fat16-superblock-volume-name)
+ (partition-field-reader read-jfs-superblock
+ jfs-superblock-volume-name)))
(define %partition-uuid-readers
(list (partition-field-reader read-iso9660-superblock
(partition-field-reader read-fat32-superblock
fat32-superblock-uuid)
(partition-field-reader read-fat16-superblock
- fat16-superblock-uuid)))
+ fat16-superblock-uuid)
+ (partition-field-reader read-jfs-superblock
+ jfs-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."
(partition-predicate read-partition-uuid uuid=?))
(define luks-partition-uuid-predicate
- (partition-predicate
- (partition-field-reader read-luks-header luks-header-uuid)
- uuid=?))
+ (partition-predicate luks-partition-field-reader uuid=?))
(define (find-partition predicate)
"Return the first partition found that matches PREDICATE, or #f if none
(match spec
((? string?)
- ;; Nothing to do.
- spec)
+ ;; Nothing to do, but wait until SPEC shows up.
+ (resolve identity spec identity))
((? file-system-label?)
;; Resolve the label.
(resolve find-partition-by-label
((string-prefix? "ext" type) check-ext2-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? "nfs" type) (const 'pass))
(else #f)))
(if check-procedure
(sleep 3)
(reboot))
('fatal-error
- (format (current-error-port)
- "File system check on ~a failed; spawning Bourne-like REPL~%"
+ (format (current-error-port) "File system check on ~a failed~%"
device)
- (start-repl %bournish-language)))
+
+ ;; 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)))
(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.
-
-DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
-FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
-run a file system check."
+ "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 #\:))
HCoop / jackhill / guix / guix.git / blobdiff