;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu build file-systems)
#:use-module (guix build utils)
+ #:use-module (guix build bournish)
#: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
;;;
;;; 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)
(loop (cons name parts))
(loop parts))))))))))
-(define (partition-label-predicate label)
- "Return a procedure that, when applied to a partition name such as \"sda1\",
-return #t if that partition's volume name is LABEL."
- (lambda (part)
- (let* ((device (string-append "/dev/" part))
- (sblock (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))))))
- (and sblock
- (let ((volume (ext2-superblock-volume-name sblock)))
- (and volume
- (string=? volume label)))))))
+(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
(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/" <>)))
+
+\f
+;;;
+;;; 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)))))))
+
+\f
(define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following:
\"/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
(define canonical-title
;; The realm of canonicalization.
(if (eq? title 'any)
- (if (string-prefix? "/" spec)
- 'device
- 'label)
+ (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.
- (let loop ((count 0))
- (let ((device (find-partition-by-label 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 label" spec)
- (begin
- (format #t "waiting for partition '~a' to appear...~%"
- spec)
- (sleep 1)
- (loop (+ 1 count))))))))
- ;; TODO: Add support for UUIDs.
+ (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 fsck
(string-append "fsck." type))
- (let ((status (system* fsck "-v" "-p" device)))
+ (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
(match (status:exit-val status)
(0
#t)
(sleep 3)
(reboot))
(code
- (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
+ (format (current-error-port) "'~a' exited with code ~a on ~a; \
+spawning Bourne-like REPL~%"
fsck code device)
- (start-repl)))))
+ (start-repl %bournish-language)))))
(define (mount-flags->bit-mask flags)
"Return the number suitable for the 'flags' argument of 'mount' that
(()
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:
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
- (mount-point (string-append root "/" mount-point)))
+ (mount-point (string-append root "/" mount-point))
+ (flags (mount-flags->bit-mask flags)))
(when check?
(check-file-system source type))
- (mkdir-p mount-point)
- (mount source mount-point type (mount-flags->bit-mask flags)
- (if options
- (string->pointer options)
- %null-pointer))
-
- ;; Update /etc/mtab.
- (mkdir-p (string-append root "/etc"))
- (let ((port (open-file (string-append root "/etc/mtab") "a")))
- (format port "~a ~a ~a ~a 0 0~%"
- source mount-point type (or options ""))
- (close-port port))))))
+
+ ;; 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
HCoop / jackhill / guix / guix.git / blobdiff