gnu/build/file-systems.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu build file-systems)
  20   #:use-module (guix build utils)
  21   #:use-module (rnrs io ports)
  22   #:use-module (rnrs bytevectors)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 rdelim)
  25   #:use-module (ice-9 format)
  26   #:use-module (system foreign)
  27   #:autoload   (system repl repl) (start-repl)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-26)
  30   #:export (disk-partitions
  31             partition-label-predicate
  32             partition-uuid-predicate
  33             find-partition-by-label
  34             find-partition-by-uuid
  35             canonicalize-device-spec
  36
  37             MS_RDONLY
  38             MS_NOSUID
  39             MS_NODEV
  40             MS_NOEXEC
  41             MS_BIND
  42             MS_MOVE
  43             bind-mount
  44
  45             mount-flags->bit-mask
  46             check-file-system
  47             mount-file-system))
  48
  49 ;;; Commentary:
  50 ;;;
  51 ;;; This modules provides tools to deal with disk partitions, and to mount and
  52 ;;; check file systems.
  53 ;;;
  54 ;;; Code:
  55
  56 ;; 'mount' is already defined in the statically linked Guile used for initial
  57 ;; RAM disks, but in all other cases the (guix build syscalls) module contains
  58 ;; the mount binding.
  59 (eval-when (expand load eval)
  60   (unless (defined? 'mount)
  61     (module-use! (current-module)
  62                  (resolve-interface '(guix build syscalls)))))
  63
  64 ;; Linux mount flags, from libc's <sys/mount.h>.
  65 (define MS_RDONLY 1)
  66 (define MS_NOSUID 2)
  67 (define MS_NODEV  4)
  68 (define MS_NOEXEC 8)
  69 (define MS_REMOUNT 32)
  70 (define MS_BIND 4096)
  71 (define MS_MOVE 8192)
  72
  73 (define (bind-mount source target)
  74   "Bind-mount SOURCE at TARGET."
  75   (mount source target "" MS_BIND))
  76
  77 (define-syntax %ext2-endianness
  78   ;; Endianness of ext2 file systems.
  79   (identifier-syntax (endianness little)))
  80
  81 ;; Offset in bytes of interesting parts of an ext2 superblock.  See
  82 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
  83 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
  84 (define-syntax %ext2-sblock-magic       (identifier-syntax 56))
  85 (define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
  86 (define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
  87 (define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
  88
  89 (define (read-ext2-superblock device)
  90   "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
  91 if DEVICE does not contain an ext2 file system."
  92   (define %ext2-magic
  93     ;; The magic bytes that identify an ext2 file system.
  94     #xef53)
  95
  96   (define superblock-size
  97     ;; Size of the interesting part of an ext2 superblock.
  98     264)
  99
 100   (define block
 101     ;; The superblock contents.
 102     (make-bytevector superblock-size))
 103
 104   (call-with-input-file device
 105     (lambda (port)
 106       (seek port 1024 SEEK_SET)
 107
 108       ;; Note: work around <http://bugs.gnu.org/17466>.
 109       (and (eqv? superblock-size (get-bytevector-n! port block 0
 110                                                     superblock-size))
 111            (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
 112                                             %ext2-endianness)))
 113              (and (= magic %ext2-magic)
 114                   block))))))
 115
 116 (define (ext2-superblock-uuid sblock)
 117   "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
 118   (let ((uuid (make-bytevector 16)))
 119     (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
 120     uuid))
 121
 122 (define (ext2-superblock-volume-name sblock)
 123   "Return the volume name of SBLOCK as a string of at most 16 characters, or
 124 #f if SBLOCK has no volume name."
 125   (let ((bv (make-bytevector 16)))
 126     (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
 127
 128     ;; This is a Latin-1, nul-terminated string.
 129     (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
 130       (if (null? bytes)
 131           #f
 132           (list->string (map integer->char bytes))))))
 133
 134 (define (disk-partitions)
 135   "Return the list of device names corresponding to valid disk partitions."
 136   (define (partition? major minor)
 137     (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
 138       (catch 'system-error
 139         (lambda ()
 140           (not (zero? (call-with-input-file marker read))))
 141         (lambda args
 142           (if (= ENOENT (system-error-errno args))
 143               #f
 144               (apply throw args))))))
 145
 146   (call-with-input-file "/proc/partitions"
 147     (lambda (port)
 148       ;; Skip the two header lines.
 149       (read-line port)
 150       (read-line port)
 151
 152       ;; Read each subsequent line, and extract the last space-separated
 153       ;; field.
 154       (let loop ((parts '()))
 155         (let ((line  (read-line port)))
 156           (if (eof-object? line)
 157               (reverse parts)
 158               (match (string-tokenize line)
 159                 (((= string->number major) (= string->number minor)
 160                   blocks name)
 161                  (if (partition? major minor)
 162                      (loop (cons name parts))
 163                      (loop parts))))))))))
 164
 165 (define (read-ext2-superblock* device)
 166   "Like 'read-ext2-superblock', but return #f when DEVICE does not exist
 167 instead of throwing an exception."
 168   (catch 'system-error
 169     (lambda ()
 170       (read-ext2-superblock device))
 171     (lambda args
 172       ;; When running on the hand-made /dev,
 173       ;; 'disk-partitions' could return partitions for which
 174       ;; we have no /dev node.  Handle that gracefully.
 175       (if (= ENOENT (system-error-errno args))
 176           (begin
 177             (format (current-error-port)
 178                     "warning: device '~a' not found~%" device)
 179             #f)
 180           (apply throw args)))))
 181
 182 (define (partition-predicate field =)
 183   "Return a predicate that returns true if the FIELD of an ext2 superblock is
 184 = to the given value."
 185   (lambda (expected)
 186     "Return a procedure that, when applied to a partition name such as \"sda1\",
 187 returns #t if that partition's volume name is LABEL."
 188     (lambda (part)
 189       (let* ((device (string-append "/dev/" part))
 190              (sblock (read-ext2-superblock* device)))
 191         (and sblock
 192              (let ((actual (field sblock)))
 193                (and actual
 194                     (= actual expected))))))))
 195
 196 (define partition-label-predicate
 197   (partition-predicate ext2-superblock-volume-name string=?))
 198
 199 (define partition-uuid-predicate
 200   (partition-predicate ext2-superblock-uuid bytevector=?))
 201
 202 (define (find-partition-by-label label)
 203   "Return the first partition found whose volume name is LABEL, or #f if none
 204 were found."
 205   (and=> (find (partition-label-predicate label)
 206                (disk-partitions))
 207          (cut string-append "/dev/" <>)))
 208
 209 (define (find-partition-by-uuid uuid)
 210   "Return the first partition whose unique identifier is UUID (a bytevector),
 211 or #f if none was found."
 212   (and=> (find (partition-uuid-predicate uuid)
 213                (disk-partitions))
 214          (cut string-append "/dev/" <>)))
 215
 216 (define-syntax %network-byte-order
 217   (identifier-syntax (endianness big)))
 218
 219 (define (uuid->string uuid)
 220   "Convert UUID, a 16-byte bytevector, to its string representation, something
 221 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
 222   ;; See <https://tools.ietf.org/html/rfc4122>.
 223   (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
 224         (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
 225         (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
 226         (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
 227         (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
 228     (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
 229             time-low time-mid time-hi clock-seq node)))
 230
 231 (define* (canonicalize-device-spec spec #:optional (title 'any))
 232   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
 233 the following:
 234
 235   • 'device', in which case SPEC is known to designate a device node--e.g.,
 236      \"/dev/sda1\";
 237   • 'label', in which case SPEC is known to designate a partition label--e.g.,
 238      \"my-root-part\";
 239   • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
 240      designating a partition;
 241   • 'any', in which case SPEC can be anything.
 242 "
 243   (define max-trials
 244     ;; Number of times we retry partition label resolution, 1 second per
 245     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
 246     ;; USB key would be detected by the kernel, so we must wait for at least
 247     ;; this long.
 248     20)
 249
 250   (define canonical-title
 251     ;; The realm of canonicalization.
 252     (if (eq? title 'any)
 253         (if (string? spec)
 254             (if (string-prefix? "/" spec)
 255                 'device
 256                 'label)
 257             'uuid)
 258         title))
 259
 260   (define (resolve find-partition spec fmt)
 261     (let loop ((count 0))
 262       (let ((device (find-partition spec)))
 263         (or device
 264             ;; Some devices take a bit of time to appear, most notably USB
 265             ;; storage devices.  Thus, wait for the device to appear.
 266             (if (> count max-trials)
 267                 (error "failed to resolve partition" (fmt spec))
 268                 (begin
 269                   (format #t "waiting for partition '~a' to appear...~%"
 270                           (fmt spec))
 271                   (sleep 1)
 272                   (loop (+ 1 count))))))))
 273
 274   (case canonical-title
 275     ((device)
 276      ;; Nothing to do.
 277      spec)
 278     ((label)
 279      ;; Resolve the label.
 280      (resolve find-partition-by-label spec identity))
 281     ((uuid)
 282      (resolve find-partition-by-uuid spec uuid->string))
 283     (else
 284      (error "unknown device title" title))))
 285
 286 (define (check-file-system device type)
 287   "Run a file system check of TYPE on DEVICE."
 288   (define fsck
 289     (string-append "fsck." type))
 290
 291   (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
 292     (match (status:exit-val status)
 293       (0
 294        #t)
 295       (1
 296        (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
 297                fsck device))
 298       (2
 299        (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
 300                fsck device)
 301        (sleep 3)
 302        (reboot))
 303       (code
 304        (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
 305                fsck code device)
 306        (start-repl)))))
 307
 308 (define (mount-flags->bit-mask flags)
 309   "Return the number suitable for the 'flags' argument of 'mount' that
 310 corresponds to the symbols listed in FLAGS."
 311   (let loop ((flags flags))
 312     (match flags
 313       (('read-only rest ...)
 314        (logior MS_RDONLY (loop rest)))
 315       (('bind-mount rest ...)
 316        (logior MS_BIND (loop rest)))
 317       (('no-suid rest ...)
 318        (logior MS_NOSUID (loop rest)))
 319       (('no-dev rest ...)
 320        (logior MS_NODEV (loop rest)))
 321       (('no-exec rest ...)
 322        (logior MS_NOEXEC (loop rest)))
 323       (()
 324        0))))
 325
 326 (define* (mount-file-system spec #:key (root "/root"))
 327   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 328 form:
 329
 330   (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 331
 332 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 333 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 334 run a file system check."
 335   (match spec
 336     ((source title mount-point type (flags ...) options check?)
 337      (let ((source      (canonicalize-device-spec source title))
 338            (mount-point (string-append root "/" mount-point))
 339            (flags       (mount-flags->bit-mask flags)))
 340        (when check?
 341          (check-file-system source type))
 342        (mkdir-p mount-point)
 343        (mount source mount-point type flags options)
 344
 345        ;; For read-only bind mounts, an extra remount is needed, as per
 346        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
 347        (when (and (= MS_BIND (logand flags MS_BIND))
 348                   (= MS_RDONLY (logand flags MS_RDONLY)))
 349          (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
 350            (mount source mount-point type flags #f)))))))
 351
 352 ;;; file-systems.scm ends here