me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/gnu/build/file-systems.scm

417 lines
15 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 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 (ice-9 regex)
#: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
uuid->string
string->uuid
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/" <>)))
;;;
;;; UUIDs.
;;;
(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 %uuid-rx
;; The regexp of a UUID.
(make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
(define (string->uuid str)
"Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
return its contents as a 16-byte bytevector. Return #f if STR is not a valid
UUID representation."
(and=> (regexp-exec %uuid-rx str)
(lambda (match)
(letrec-syntax ((hex->number
(syntax-rules ()
((_ index)
(string->number (match:substring match index)
16))))
(put!
(syntax-rules ()
((_ bv index (number len) rest ...)
(begin
(bytevector-uint-set! bv index number
(endianness big) len)
(put! bv (+ index len) rest ...)))
((_ bv index)
bv))))
(let ((time-low (hex->number 1))
(time-mid (hex->number 2))
(time-hi (hex->number 3))
(clock-seq (hex->number 4))
(node (hex->number 5))
(uuid (make-bytevector 16)))
(put! uuid 0
(time-low 4) (time-mid 2) (time-hi 2)
(clock-seq 2) (node 6)))))))
(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)
;; The "--root=SPEC" kernel command-line option always provides a
;; string, but the string can represent a device, a UUID, or a
;; label. So check for all three.
(cond ((string-prefix? "/" spec) 'device)
((string->uuid spec) 'uuid)
(else '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
(if (string? spec)
(string->uuid spec)
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))
(unless (file-exists? mount-point)
(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