366 lines
13 KiB
Scheme
366 lines
13 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
|
;;;
|
|
;;; 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 (guix build utils)
|
|
#:use-module (rnrs io ports)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (ice-9 format)
|
|
#: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
|
|
find-partition-by-label
|
|
find-partition-by-uuid
|
|
canonicalize-device-spec
|
|
|
|
MS_RDONLY
|
|
MS_NOSUID
|
|
MS_NODEV
|
|
MS_NOEXEC
|
|
MS_BIND
|
|
MS_MOVE
|
|
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:
|
|
|
|
;; 'mount' is already defined in the statically linked Guile used for initial
|
|
;; RAM disks, but in all other cases the (guix build syscalls) module contains
|
|
;; the mount binding.
|
|
(eval-when (expand load eval)
|
|
(unless (defined? 'mount)
|
|
(module-use! (current-module)
|
|
(resolve-interface '(guix build syscalls)))))
|
|
|
|
;; Linux mount flags, from libc's <sys/mount.h>.
|
|
(define MS_RDONLY 1)
|
|
(define MS_NOSUID 2)
|
|
(define MS_NODEV 4)
|
|
(define MS_NOEXEC 8)
|
|
(define MS_REMOUNT 32)
|
|
(define MS_BIND 4096)
|
|
(define MS_MOVE 8192)
|
|
|
|
(define (bind-mount source target)
|
|
"Bind-mount SOURCE at TARGET."
|
|
(mount source target "" MS_BIND))
|
|
|
|
(define-syntax %ext2-endianness
|
|
;; Endianness of ext2 file systems.
|
|
(identifier-syntax (endianness little)))
|
|
|
|
;; Offset in bytes of interesting parts of an ext2 superblock. See
|
|
;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
|
|
;; TODO: Use "packed structs" from Guile-OpenGL or similar.
|
|
(define-syntax %ext2-sblock-magic (identifier-syntax 56))
|
|
(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
|
|
(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
|
|
(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
|
|
|
|
(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."
|
|
(define %ext2-magic
|
|
;; The magic bytes that identify an ext2 file system.
|
|
#xef53)
|
|
|
|
(define superblock-size
|
|
;; Size of the interesting part of an ext2 superblock.
|
|
264)
|
|
|
|
(define block
|
|
;; The superblock contents.
|
|
(make-bytevector superblock-size))
|
|
|
|
(call-with-input-file device
|
|
(lambda (port)
|
|
(seek port 1024 SEEK_SET)
|
|
|
|
;; Note: work around <http://bugs.gnu.org/17466>.
|
|
(and (eqv? superblock-size (get-bytevector-n! port block 0
|
|
superblock-size))
|
|
(let ((magic (bytevector-u16-ref block %ext2-sblock-magic
|
|
%ext2-endianness)))
|
|
(and (= magic %ext2-magic)
|
|
block))))))
|
|
|
|
(define (ext2-superblock-uuid sblock)
|
|
"Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
|
|
(let ((uuid (make-bytevector 16)))
|
|
(bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
|
|
uuid))
|
|
|
|
(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."
|
|
(let ((bv (make-bytevector 16)))
|
|
(bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
|
|
|
|
;; This is a Latin-1, nul-terminated string.
|
|
(let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
|
|
(if (null? bytes)
|
|
#f
|
|
(list->string (map integer->char bytes))))))
|
|
|
|
(define (disk-partitions)
|
|
"Return the list of device names corresponding to valid disk partitions."
|
|
(define (partition? major minor)
|
|
(let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(not (zero? (call-with-input-file marker read))))
|
|
(lambda args
|
|
(if (= ENOENT (system-error-errno args))
|
|
#f
|
|
(apply throw args))))))
|
|
|
|
(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? major minor)
|
|
(loop (cons name parts))
|
|
(loop parts))))))))))
|
|
|
|
(define (read-ext2-superblock* device)
|
|
"Like 'read-ext2-superblock', but return #f when DEVICE does not exist
|
|
instead of throwing an exception."
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(read-ext2-superblock 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.
|
|
(if (= ENOENT (system-error-errno args))
|
|
(begin
|
|
(format (current-error-port)
|
|
"warning: device '~a' not found~%" device)
|
|
#f)
|
|
(apply throw args)))))
|
|
|
|
(define (partition-predicate field =)
|
|
"Return a predicate that returns true if the FIELD of an ext2 superblock is
|
|
= to the given value."
|
|
(lambda (expected)
|
|
"Return a procedure that, when applied to a partition name such as \"sda1\",
|
|
returns #t if that partition's volume name is LABEL."
|
|
(lambda (part)
|
|
(let* ((device (string-append "/dev/" part))
|
|
(sblock (read-ext2-superblock* device)))
|
|
(and sblock
|
|
(let ((actual (field sblock)))
|
|
(and actual
|
|
(= actual expected))))))))
|
|
|
|
(define partition-label-predicate
|
|
(partition-predicate ext2-superblock-volume-name string=?))
|
|
|
|
(define partition-uuid-predicate
|
|
(partition-predicate ext2-superblock-uuid bytevector=?))
|
|
|
|
(define (find-partition-by-label label)
|
|
"Return the first partition found whose volume name is LABEL, or #f if none
|
|
were found."
|
|
(and=> (find (partition-label-predicate label)
|
|
(disk-partitions))
|
|
(cut string-append "/dev/" <>)))
|
|
|
|
(define (find-partition-by-uuid uuid)
|
|
"Return the first partition whose unique identifier is UUID (a bytevector),
|
|
or #f if none was found."
|
|
(and=> (find (partition-uuid-predicate uuid)
|
|
(disk-partitions))
|
|
(cut string-append "/dev/" <>)))
|
|
|
|
(define-syntax %network-byte-order
|
|
(identifier-syntax (endianness big)))
|
|
|
|
(define (uuid->string uuid)
|
|
"Convert UUID, a 16-byte bytevector, to its string representation, something
|
|
like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
|
|
;; See <https://tools.ietf.org/html/rfc4122>.
|
|
(let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
|
|
(time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
|
|
(time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
|
|
(clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
|
|
(node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
|
|
(format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
|
|
time-low time-mid time-hi clock-seq node)))
|
|
|
|
(define* (canonicalize-device-spec spec #:optional (title 'any))
|
|
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
|
|
the following:
|
|
|
|
• 'device', in which case SPEC is known to designate a device node--e.g.,
|
|
\"/dev/sda1\";
|
|
• 'label', in which case SPEC is known to designate a partition label--e.g.,
|
|
\"my-root-part\";
|
|
• 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
|
|
designating a partition;
|
|
• 'any', in which case SPEC can be anything.
|
|
"
|
|
(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 canonical-title
|
|
;; The realm of canonicalization.
|
|
(if (eq? title 'any)
|
|
(if (string? spec)
|
|
(if (string-prefix? "/" spec)
|
|
'device
|
|
'label)
|
|
'uuid)
|
|
title))
|
|
|
|
(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))))))))
|
|
|
|
(case canonical-title
|
|
((device)
|
|
;; Nothing to do.
|
|
spec)
|
|
((label)
|
|
;; Resolve the label.
|
|
(resolve find-partition-by-label spec identity))
|
|
((uuid)
|
|
(resolve find-partition-by-uuid spec uuid->string))
|
|
(else
|
|
(error "unknown device title" title))))
|
|
|
|
(define (check-file-system device type)
|
|
"Run a file system check of TYPE on DEVICE."
|
|
(define fsck
|
|
(string-append "fsck." type))
|
|
|
|
(let ((status (system* fsck "-v" "-p" "-C" "0" device)))
|
|
(match (status:exit-val status)
|
|
(0
|
|
#t)
|
|
(1
|
|
(format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
|
|
fsck device))
|
|
(2
|
|
(format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
|
|
fsck device)
|
|
(sleep 3)
|
|
(reboot))
|
|
(code
|
|
(format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
|
|
fsck code device)
|
|
(start-repl)))))
|
|
|
|
(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)))
|
|
(()
|
|
0))))
|
|
|
|
(define (regular-file? file-name)
|
|
"Return #t if FILE-NAME is a regular file."
|
|
(eq? (stat:type (stat file-name)) 'regular))
|
|
|
|
(define* (mount-file-system spec #:key (root "/root"))
|
|
"Mount the file system described by SPEC under ROOT. SPEC must have the
|
|
form:
|
|
|
|
(DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
|
|
|
|
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."
|
|
(match spec
|
|
((source title mount-point type (flags ...) options check?)
|
|
(let ((source (canonicalize-device-spec source title))
|
|
(mount-point (string-append root "/" mount-point))
|
|
(flags (mount-flags->bit-mask flags)))
|
|
(when check?
|
|
(check-file-system source type))
|
|
|
|
;; Create the mount point. Most of the time this is a directory, but
|
|
;; in the case of a bind mount, a regular file may be needed.
|
|
(if (and (= MS_BIND (logand flags MS_BIND))
|
|
(regular-file? source))
|
|
(begin
|
|
(mkdir-p (dirname mount-point))
|
|
(call-with-output-file mount-point (const #t)))
|
|
(mkdir-p mount-point))
|
|
|
|
(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)))))))
|
|
|
|
;;; file-systems.scm ends here
|