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 (system foreign)
  26   #:autoload   (system repl repl) (start-repl)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:export (disk-partitions
  30             partition-label-predicate
  31             find-partition-by-label
  32             canonicalize-device-spec
  33
  34             MS_RDONLY
  35             MS_NOSUID
  36             MS_NODEV
  37             MS_NOEXEC
  38             MS_BIND
  39             MS_MOVE
  40             bind-mount
  41
  42             mount-flags->bit-mask
  43             check-file-system
  44             mount-file-system))
  45
  46 ;;; Commentary:
  47 ;;;
  48 ;;; This modules provides tools to deal with disk partitions, and to mount and
  49 ;;; check file systems.
  50 ;;;
  51 ;;; Code:
  52
  53 ;; Linux mount flags, from libc's <sys/mount.h>.
  54 (define MS_RDONLY 1)
  55 (define MS_NOSUID 2)
  56 (define MS_NODEV  4)
  57 (define MS_NOEXEC 8)
  58 (define MS_REMOUNT 32)
  59 (define MS_BIND 4096)
  60 (define MS_MOVE 8192)
  61
  62 (define (bind-mount source target)
  63   "Bind-mount SOURCE at TARGET."
  64   (mount source target "" MS_BIND))
  65
  66 (define-syntax %ext2-endianness
  67   ;; Endianness of ext2 file systems.
  68   (identifier-syntax (endianness little)))
  69
  70 ;; Offset in bytes of interesting parts of an ext2 superblock.  See
  71 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
  72 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
  73 (define-syntax %ext2-sblock-magic       (identifier-syntax 56))
  74 (define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
  75 (define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
  76 (define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
  77
  78 (define (read-ext2-superblock device)
  79   "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
  80 if DEVICE does not contain an ext2 file system."
  81   (define %ext2-magic
  82     ;; The magic bytes that identify an ext2 file system.
  83     #xef53)
  84
  85   (define superblock-size
  86     ;; Size of the interesting part of an ext2 superblock.
  87     264)
  88
  89   (define block
  90     ;; The superblock contents.
  91     (make-bytevector superblock-size))
  92
  93   (call-with-input-file device
  94     (lambda (port)
  95       (seek port 1024 SEEK_SET)
  96
  97       ;; Note: work around <http://bugs.gnu.org/17466>.
  98       (and (eqv? superblock-size (get-bytevector-n! port block 0
  99                                                     superblock-size))
 100            (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
 101                                             %ext2-endianness)))
 102              (and (= magic %ext2-magic)
 103                   block))))))
 104
 105 (define (ext2-superblock-uuid sblock)
 106   "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
 107   (let ((uuid (make-bytevector 16)))
 108     (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
 109     uuid))
 110
 111 (define (ext2-superblock-volume-name sblock)
 112   "Return the volume name of SBLOCK as a string of at most 16 characters, or
 113 #f if SBLOCK has no volume name."
 114   (let ((bv (make-bytevector 16)))
 115     (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
 116
 117     ;; This is a Latin-1, nul-terminated string.
 118     (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
 119       (if (null? bytes)
 120           #f
 121           (list->string (map integer->char bytes))))))
 122
 123 (define (disk-partitions)
 124   "Return the list of device names corresponding to valid disk partitions."
 125   (define (partition? major minor)
 126     (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
 127       (catch 'system-error
 128         (lambda ()
 129           (not (zero? (call-with-input-file marker read))))
 130         (lambda args
 131           (if (= ENOENT (system-error-errno args))
 132               #f
 133               (apply throw args))))))
 134
 135   (call-with-input-file "/proc/partitions"
 136     (lambda (port)
 137       ;; Skip the two header lines.
 138       (read-line port)
 139       (read-line port)
 140
 141       ;; Read each subsequent line, and extract the last space-separated
 142       ;; field.
 143       (let loop ((parts '()))
 144         (let ((line  (read-line port)))
 145           (if (eof-object? line)
 146               (reverse parts)
 147               (match (string-tokenize line)
 148                 (((= string->number major) (= string->number minor)
 149                   blocks name)
 150                  (if (partition? major minor)
 151                      (loop (cons name parts))
 152                      (loop parts))))))))))
 153
 154 (define (partition-label-predicate label)
 155   "Return a procedure that, when applied to a partition name such as \"sda1\",
 156 return #t if that partition's volume name is LABEL."
 157   (lambda (part)
 158     (let* ((device (string-append "/dev/" part))
 159            (sblock (catch 'system-error
 160                      (lambda ()
 161                        (read-ext2-superblock device))
 162                      (lambda args
 163                        ;; When running on the hand-made /dev,
 164                        ;; 'disk-partitions' could return partitions for which
 165                        ;; we have no /dev node.  Handle that gracefully.
 166                        (if (= ENOENT (system-error-errno args))
 167                            (begin
 168                              (format (current-error-port)
 169                                      "warning: device '~a' not found~%"
 170                                      device)
 171                              #f)
 172                            (apply throw args))))))
 173       (and sblock
 174            (let ((volume (ext2-superblock-volume-name sblock)))
 175              (and volume
 176                   (string=? volume label)))))))
 177
 178 (define (find-partition-by-label label)
 179   "Return the first partition found whose volume name is LABEL, or #f if none
 180 were found."
 181   (and=> (find (partition-label-predicate label)
 182                (disk-partitions))
 183          (cut string-append "/dev/" <>)))
 184
 185 (define* (canonicalize-device-spec spec #:optional (title 'any))
 186   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
 187 the following:
 188
 189   • 'device', in which case SPEC is known to designate a device node--e.g.,
 190      \"/dev/sda1\";
 191   • 'label', in which case SPEC is known to designate a partition label--e.g.,
 192      \"my-root-part\";
 193   • 'any', in which case SPEC can be anything.
 194 "
 195   (define max-trials
 196     ;; Number of times we retry partition label resolution, 1 second per
 197     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
 198     ;; USB key would be detected by the kernel, so we must wait for at least
 199     ;; this long.
 200     20)
 201
 202   (define canonical-title
 203     ;; The realm of canonicalization.
 204     (if (eq? title 'any)
 205         (if (string-prefix? "/" spec)
 206             'device
 207             'label)
 208         title))
 209
 210   (case canonical-title
 211     ((device)
 212      ;; Nothing to do.
 213      spec)
 214     ((label)
 215      ;; Resolve the label.
 216      (let loop ((count 0))
 217        (let ((device (find-partition-by-label spec)))
 218          (or device
 219              ;; Some devices take a bit of time to appear, most notably USB
 220              ;; storage devices.  Thus, wait for the device to appear.
 221              (if (> count max-trials)
 222                  (error "failed to resolve partition label" spec)
 223                  (begin
 224                    (format #t "waiting for partition '~a' to appear...~%"
 225                            spec)
 226                    (sleep 1)
 227                    (loop (+ 1 count))))))))
 228     ;; TODO: Add support for UUIDs.
 229     (else
 230      (error "unknown device title" title))))
 231
 232 (define (check-file-system device type)
 233   "Run a file system check of TYPE on DEVICE."
 234   (define fsck
 235     (string-append "fsck." type))
 236
 237   (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
 238     (match (status:exit-val status)
 239       (0
 240        #t)
 241       (1
 242        (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
 243                fsck device))
 244       (2
 245        (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
 246                fsck device)
 247        (sleep 3)
 248        (reboot))
 249       (code
 250        (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
 251                fsck code device)
 252        (start-repl)))))
 253
 254 (define (mount-flags->bit-mask flags)
 255   "Return the number suitable for the 'flags' argument of 'mount' that
 256 corresponds to the symbols listed in FLAGS."
 257   (let loop ((flags flags))
 258     (match flags
 259       (('read-only rest ...)
 260        (logior MS_RDONLY (loop rest)))
 261       (('bind-mount rest ...)
 262        (logior MS_BIND (loop rest)))
 263       (('no-suid rest ...)
 264        (logior MS_NOSUID (loop rest)))
 265       (('no-dev rest ...)
 266        (logior MS_NODEV (loop rest)))
 267       (('no-exec rest ...)
 268        (logior MS_NOEXEC (loop rest)))
 269       (()
 270        0))))
 271
 272 (define* (mount-file-system spec #:key (root "/root"))
 273   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 274 form:
 275
 276   (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 277
 278 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 279 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 280 run a file system check."
 281   (match spec
 282     ((source title mount-point type (flags ...) options check?)
 283      (let ((source      (canonicalize-device-spec source title))
 284            (mount-point (string-append root "/" mount-point))
 285            (flags       (mount-flags->bit-mask flags)))
 286        (when check?
 287          (check-file-system source type))
 288        (mkdir-p mount-point)
 289        (mount source mount-point type flags options)
 290
 291        ;; For read-only bind mounts, an extra remount is needed, as per
 292        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
 293        (when (and (= MS_BIND (logand flags MS_BIND))
 294                   (= MS_RDONLY (logand flags MS_RDONLY)))
 295          (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
 296            (mount source mount-point type flags #f)))))))
 297
 298 ;;; file-systems.scm ends here