gnu/build/file-systems.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016 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 (guix build bournish)
  22   #:use-module (guix build syscalls)
  23   #:use-module (rnrs io ports)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (ice-9 format)
  28   #:use-module (ice-9 regex)
  29   #:use-module (system foreign)
  30   #:autoload   (system repl repl) (start-repl)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-26)
  33   #:export (disk-partitions
  34             partition-label-predicate
  35             partition-uuid-predicate
  36             partition-luks-uuid-predicate
  37             find-partition-by-label
  38             find-partition-by-uuid
  39             find-partition-by-luks-uuid
  40             canonicalize-device-spec
  41
  42             uuid->string
  43             string->uuid
  44
  45             bind-mount
  46
  47             mount-flags->bit-mask
  48             check-file-system
  49             mount-file-system)
  50   #:re-export (mount
  51                umount
  52                MS_BIND
  53                MS_MOVE
  54                MS_RDONLY))
  55
  56 ;;; Commentary:
  57 ;;;
  58 ;;; This modules provides tools to deal with disk partitions, and to mount and
  59 ;;; check file systems.
  60 ;;;
  61 ;;; Code:
  62
  63 ;; 'mount' is already defined in the statically linked Guile used for initial
  64 ;; RAM disks, in which case the bindings in (guix build syscalls) do not work
  65 ;; (the FFI bindings do not work there).  Override them in that case.
  66 (when (module-defined? the-scm-module 'mount)
  67   (set! mount (@ (guile) mount))
  68   (set! umount (@ (guile) umount)))
  69
  70 (define (bind-mount source target)
  71   "Bind-mount SOURCE at TARGET."
  72   (mount source target "" MS_BIND))
  73
  74 \f
  75 ;;;
  76 ;;; Ext2 file systems.
  77 ;;;
  78
  79 (define-syntax %ext2-endianness
  80   ;; Endianness of ext2 file systems.
  81   (identifier-syntax (endianness little)))
  82
  83 ;; Offset in bytes of interesting parts of an ext2 superblock.  See
  84 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
  85 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
  86 (define-syntax %ext2-sblock-magic       (identifier-syntax 56))
  87 (define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
  88 (define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
  89 (define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
  90
  91 (define (read-ext2-superblock device)
  92   "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
  93 if DEVICE does not contain an ext2 file system."
  94   (define %ext2-magic
  95     ;; The magic bytes that identify an ext2 file system.
  96     #xef53)
  97
  98   (define superblock-size
  99     ;; Size of the interesting part of an ext2 superblock.
 100     264)
 101
 102   (define block
 103     ;; The superblock contents.
 104     (make-bytevector superblock-size))
 105
 106   (call-with-input-file device
 107     (lambda (port)
 108       (seek port 1024 SEEK_SET)
 109
 110       ;; Note: work around <http://bugs.gnu.org/17466>.
 111       (and (eqv? superblock-size (get-bytevector-n! port block 0
 112                                                     superblock-size))
 113            (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
 114                                             %ext2-endianness)))
 115              (and (= magic %ext2-magic)
 116                   block))))))
 117
 118 (define (ext2-superblock-uuid sblock)
 119   "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
 120   (let ((uuid (make-bytevector 16)))
 121     (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
 122     uuid))
 123
 124 (define (ext2-superblock-volume-name sblock)
 125   "Return the volume name of SBLOCK as a string of at most 16 characters, or
 126 #f if SBLOCK has no volume name."
 127   (let ((bv (make-bytevector 16)))
 128     (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
 129
 130     ;; This is a Latin-1, nul-terminated string.
 131     (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
 132       (if (null? bytes)
 133           #f
 134           (list->string (map integer->char bytes))))))
 135
 136 \f
 137 ;;;
 138 ;;; LUKS encrypted devices.
 139 ;;;
 140
 141 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
 142 ;; <http://wiki.cryptsetup.googlecode.com/git/LUKS-standard/>.  We follow
 143 ;; version 1.2.1 of this document.
 144
 145 (define-syntax %luks-endianness
 146   ;; Endianness of LUKS headers.
 147   (identifier-syntax (endianness big)))
 148
 149 (define-syntax %luks-header-size
 150   ;; Size in bytes of the LUKS header, including key slots.
 151   (identifier-syntax 592))
 152
 153 (define %luks-magic
 154   ;; The 'LUKS_MAGIC' constant.
 155   (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
 156                                (list #xba #xbe))))
 157
 158 (define (sub-bytevector bv start size)
 159   "Return a copy of the SIZE bytes of BV starting from offset START."
 160   (let ((result (make-bytevector size)))
 161     (bytevector-copy! bv start result 0 size)
 162     result))
 163
 164 (define (read-luks-header file)
 165   "Read a LUKS header from FILE.  Return the raw header on success, and #f if
 166 not valid header was found."
 167   (call-with-input-file file
 168     (lambda (port)
 169       (let ((header (make-bytevector %luks-header-size)))
 170         (match (get-bytevector-n! port header 0 (bytevector-length header))
 171           ((? eof-object?)
 172            #f)
 173           ((? number? len)
 174            (and (= len (bytevector-length header))
 175                 (let ((magic   (sub-bytevector header 0 6)) ;XXX: inefficient
 176                       (version (bytevector-u16-ref header 6 %luks-endianness)))
 177                   (and (bytevector=? magic %luks-magic)
 178                        (= version 1)
 179                        header)))))))))
 180
 181 (define (luks-header-uuid header)
 182   "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
 183   ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
 184   ;; bytes of its ASCII representation.
 185   (let ((uuid (sub-bytevector header 168 36)))
 186     (string->uuid (utf8->string uuid))))
 187
 188 \f
 189 ;;;
 190 ;;; Partition lookup.
 191 ;;;
 192
 193 (define (disk-partitions)
 194   "Return the list of device names corresponding to valid disk partitions."
 195   (define (partition? major minor)
 196     (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
 197       (catch 'system-error
 198         (lambda ()
 199           (not (zero? (call-with-input-file marker read))))
 200         (lambda args
 201           (if (= ENOENT (system-error-errno args))
 202               #f
 203               (apply throw args))))))
 204
 205   (call-with-input-file "/proc/partitions"
 206     (lambda (port)
 207       ;; Skip the two header lines.
 208       (read-line port)
 209       (read-line port)
 210
 211       ;; Read each subsequent line, and extract the last space-separated
 212       ;; field.
 213       (let loop ((parts '()))
 214         (let ((line  (read-line port)))
 215           (if (eof-object? line)
 216               (reverse parts)
 217               (match (string-tokenize line)
 218                 (((= string->number major) (= string->number minor)
 219                   blocks name)
 220                  (if (partition? major minor)
 221                      (loop (cons name parts))
 222                      (loop parts))))))))))
 223
 224 (define (ENOENT-safe proc)
 225   "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
 226 warning and #f as the result."
 227   (lambda (device)
 228     (catch 'system-error
 229       (lambda ()
 230         (proc device))
 231       (lambda args
 232         ;; When running on the hand-made /dev,
 233         ;; 'disk-partitions' could return partitions for which
 234         ;; we have no /dev node.  Handle that gracefully.
 235         (if (= ENOENT (system-error-errno args))
 236             (begin
 237               (format (current-error-port)
 238                       "warning: device '~a' not found~%" device)
 239               #f)
 240             (apply throw args))))))
 241
 242 (define (partition-predicate read field =)
 243   "Return a predicate that returns true if the FIELD of partition header that
 244 was READ is = to the given value."
 245   (let ((read (ENOENT-safe read)))
 246     (lambda (expected)
 247       "Return a procedure that, when applied to a partition name such as \"sda1\",
 248 returns #t if that partition's volume name is LABEL."
 249       (lambda (part)
 250         (let* ((device (string-append "/dev/" part))
 251                (sblock (read device)))
 252           (and sblock
 253                (let ((actual (field sblock)))
 254                  (and actual
 255                       (= actual expected)))))))))
 256
 257 (define partition-label-predicate
 258   (partition-predicate read-ext2-superblock
 259                        ext2-superblock-volume-name
 260                        string=?))
 261
 262 (define partition-uuid-predicate
 263   (partition-predicate read-ext2-superblock
 264                        ext2-superblock-uuid
 265                        bytevector=?))
 266
 267 (define partition-luks-uuid-predicate
 268   (partition-predicate read-luks-header
 269                        luks-header-uuid
 270                        bytevector=?))
 271
 272 (define (find-partition-by-label label)
 273   "Return the first partition found whose volume name is LABEL, or #f if none
 274 were found."
 275   (and=> (find (partition-label-predicate label)
 276                (disk-partitions))
 277          (cut string-append "/dev/" <>)))
 278
 279 (define (find-partition-by-uuid uuid)
 280   "Return the first partition whose unique identifier is UUID (a bytevector),
 281 or #f if none was found."
 282   (and=> (find (partition-uuid-predicate uuid)
 283                (disk-partitions))
 284          (cut string-append "/dev/" <>)))
 285
 286 (define (find-partition-by-luks-uuid uuid)
 287   "Return the first LUKS partition whose unique identifier is UUID (a bytevector),
 288 or #f if none was found."
 289   (and=> (find (partition-luks-uuid-predicate uuid)
 290                (disk-partitions))
 291          (cut string-append "/dev/" <>)))
 292
 293 \f
 294 ;;;
 295 ;;; UUIDs.
 296 ;;;
 297
 298 (define-syntax %network-byte-order
 299   (identifier-syntax (endianness big)))
 300
 301 (define (uuid->string uuid)
 302   "Convert UUID, a 16-byte bytevector, to its string representation, something
 303 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
 304   ;; See <https://tools.ietf.org/html/rfc4122>.
 305   (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
 306         (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
 307         (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
 308         (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
 309         (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
 310     (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
 311             time-low time-mid time-hi clock-seq node)))
 312
 313 (define %uuid-rx
 314   ;; The regexp of a UUID.
 315   (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
 316
 317 (define (string->uuid str)
 318   "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
 319 return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
 320 UUID representation."
 321   (and=> (regexp-exec %uuid-rx str)
 322          (lambda (match)
 323            (letrec-syntax ((hex->number
 324                             (syntax-rules ()
 325                               ((_ index)
 326                                (string->number (match:substring match index)
 327                                                16))))
 328                            (put!
 329                             (syntax-rules ()
 330                               ((_ bv index (number len) rest ...)
 331                                (begin
 332                                  (bytevector-uint-set! bv index number
 333                                                        (endianness big) len)
 334                                  (put! bv (+ index len) rest ...)))
 335                               ((_ bv index)
 336                                bv))))
 337              (let ((time-low  (hex->number 1))
 338                    (time-mid  (hex->number 2))
 339                    (time-hi   (hex->number 3))
 340                    (clock-seq (hex->number 4))
 341                    (node      (hex->number 5))
 342                    (uuid      (make-bytevector 16)))
 343                (put! uuid 0
 344                      (time-low 4) (time-mid 2) (time-hi 2)
 345                      (clock-seq 2) (node 6)))))))
 346
 347 \f
 348 (define* (canonicalize-device-spec spec #:optional (title 'any))
 349   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
 350 the following:
 351
 352   • 'device', in which case SPEC is known to designate a device node--e.g.,
 353      \"/dev/sda1\";
 354   • 'label', in which case SPEC is known to designate a partition label--e.g.,
 355      \"my-root-part\";
 356   • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
 357      designating a partition;
 358   • 'any', in which case SPEC can be anything.
 359 "
 360   (define max-trials
 361     ;; Number of times we retry partition label resolution, 1 second per
 362     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
 363     ;; USB key would be detected by the kernel, so we must wait for at least
 364     ;; this long.
 365     20)
 366
 367   (define canonical-title
 368     ;; The realm of canonicalization.
 369     (if (eq? title 'any)
 370         (if (string? spec)
 371             ;; The "--root=SPEC" kernel command-line option always provides a
 372             ;; string, but the string can represent a device, a UUID, or a
 373             ;; label.  So check for all three.
 374             (cond ((string-prefix? "/" spec) 'device)
 375                   ((string->uuid spec) 'uuid)
 376                   (else 'label))
 377             'uuid)
 378         title))
 379
 380   (define (resolve find-partition spec fmt)
 381     (let loop ((count 0))
 382       (let ((device (find-partition spec)))
 383         (or device
 384             ;; Some devices take a bit of time to appear, most notably USB
 385             ;; storage devices.  Thus, wait for the device to appear.
 386             (if (> count max-trials)
 387                 (error "failed to resolve partition" (fmt spec))
 388                 (begin
 389                   (format #t "waiting for partition '~a' to appear...~%"
 390                           (fmt spec))
 391                   (sleep 1)
 392                   (loop (+ 1 count))))))))
 393
 394   (case canonical-title
 395     ((device)
 396      ;; Nothing to do.
 397      spec)
 398     ((label)
 399      ;; Resolve the label.
 400      (resolve find-partition-by-label spec identity))
 401     ((uuid)
 402      (resolve find-partition-by-uuid
 403               (if (string? spec)
 404                   (string->uuid spec)
 405                   spec)
 406               uuid->string))
 407     (else
 408      (error "unknown device title" title))))
 409
 410 (define (check-file-system device type)
 411   "Run a file system check of TYPE on DEVICE."
 412   (define fsck
 413     (string-append "fsck." type))
 414
 415   (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
 416     (match (status:exit-val status)
 417       (0
 418        #t)
 419       (1
 420        (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
 421                fsck device))
 422       (2
 423        (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
 424                fsck device)
 425        (sleep 3)
 426        (reboot))
 427       (code
 428        (format (current-error-port) "'~a' exited with code ~a on ~a; \
 429 spawning Bourne-like REPL~%"
 430                fsck code device)
 431        (start-repl %bournish-language)))))
 432
 433 (define (mount-flags->bit-mask flags)
 434   "Return the number suitable for the 'flags' argument of 'mount' that
 435 corresponds to the symbols listed in FLAGS."
 436   (let loop ((flags flags))
 437     (match flags
 438       (('read-only rest ...)
 439        (logior MS_RDONLY (loop rest)))
 440       (('bind-mount rest ...)
 441        (logior MS_BIND (loop rest)))
 442       (('no-suid rest ...)
 443        (logior MS_NOSUID (loop rest)))
 444       (('no-dev rest ...)
 445        (logior MS_NODEV (loop rest)))
 446       (('no-exec rest ...)
 447        (logior MS_NOEXEC (loop rest)))
 448       (()
 449        0))))
 450
 451 (define (regular-file? file-name)
 452   "Return #t if FILE-NAME is a regular file."
 453   (eq? (stat:type (stat file-name)) 'regular))
 454
 455 (define* (mount-file-system spec #:key (root "/root"))
 456   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 457 form:
 458
 459   (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 460
 461 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 462 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 463 run a file system check."
 464   (match spec
 465     ((source title mount-point type (flags ...) options check?)
 466      (let ((source      (canonicalize-device-spec source title))
 467            (mount-point (string-append root "/" mount-point))
 468            (flags       (mount-flags->bit-mask flags)))
 469        (when check?
 470          (check-file-system source type))
 471
 472        ;; Create the mount point.  Most of the time this is a directory, but
 473        ;; in the case of a bind mount, a regular file may be needed.
 474        (if (and (= MS_BIND (logand flags MS_BIND))
 475                 (regular-file? source))
 476            (unless (file-exists? mount-point)
 477              (mkdir-p (dirname mount-point))
 478              (call-with-output-file mount-point (const #t)))
 479            (mkdir-p mount-point))
 480
 481        (mount source mount-point type flags options)
 482
 483        ;; For read-only bind mounts, an extra remount is needed, as per
 484        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
 485        (when (and (= MS_BIND (logand flags MS_BIND))
 486                   (= MS_RDONLY (logand flags MS_RDONLY)))
 487          (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
 488            (mount source mount-point type flags #f)))))))
 489
 490 ;;; file-systems.scm ends here