gnu/build/file-systems.scm

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