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 (last-character str)
 196     (string-ref str (- (string-length str) 1)))
 197
 198   (define (partition? name major minor)
 199     ;; Select device names that end in a digit, like libblkid's 'probe_all'
 200     ;; function does.  Checking for "/sys/dev/block/MAJOR:MINOR/partition"
 201     ;; doesn't work for partitions coming from mapped devices.
 202     (and (char-set-contains? char-set:digit (last-character name))
 203          (> major 2)))                      ;ignore RAM disks and floppy disks
 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? name 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         (let ((errno (system-error-errno args)))
 236           (cond ((= ENOENT errno)
 237                  (format (current-error-port)
 238                          "warning: device '~a' not found~%" device)
 239                  #f)
 240                 ((= ENOMEDIUM errno)              ;for removable media
 241                  #f)
 242                 (else
 243                  (apply throw args))))))))
 244
 245 (define (partition-predicate read field =)
 246   "Return a predicate that returns true if the FIELD of partition header that
 247 was READ is = to the given value."
 248   (let ((read (ENOENT-safe read)))
 249     (lambda (expected)
 250       "Return a procedure that, when applied to a partition name such as \"sda1\",
 251 returns #t if that partition's volume name is LABEL."
 252       (lambda (part)
 253         (let* ((device (string-append "/dev/" part))
 254                (sblock (read device)))
 255           (and sblock
 256                (let ((actual (field sblock)))
 257                  (and actual
 258                       (= actual expected)))))))))
 259
 260 (define partition-label-predicate
 261   (partition-predicate read-ext2-superblock
 262                        ext2-superblock-volume-name
 263                        string=?))
 264
 265 (define partition-uuid-predicate
 266   (partition-predicate read-ext2-superblock
 267                        ext2-superblock-uuid
 268                        bytevector=?))
 269
 270 (define partition-luks-uuid-predicate
 271   (partition-predicate read-luks-header
 272                        luks-header-uuid
 273                        bytevector=?))
 274
 275 (define (find-partition-by-label label)
 276   "Return the first partition found whose volume name is LABEL, or #f if none
 277 were found."
 278   (and=> (find (partition-label-predicate label)
 279                (disk-partitions))
 280          (cut string-append "/dev/" <>)))
 281
 282 (define (find-partition-by-uuid uuid)
 283   "Return the first partition whose unique identifier is UUID (a bytevector),
 284 or #f if none was found."
 285   (and=> (find (partition-uuid-predicate uuid)
 286                (disk-partitions))
 287          (cut string-append "/dev/" <>)))
 288
 289 (define (find-partition-by-luks-uuid uuid)
 290   "Return the first LUKS partition whose unique identifier is UUID (a bytevector),
 291 or #f if none was found."
 292   (and=> (find (partition-luks-uuid-predicate uuid)
 293                (disk-partitions))
 294          (cut string-append "/dev/" <>)))
 295
 296 \f
 297 ;;;
 298 ;;; UUIDs.
 299 ;;;
 300
 301 (define-syntax %network-byte-order
 302   (identifier-syntax (endianness big)))
 303
 304 (define (uuid->string uuid)
 305   "Convert UUID, a 16-byte bytevector, to its string representation, something
 306 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
 307   ;; See <https://tools.ietf.org/html/rfc4122>.
 308   (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
 309         (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
 310         (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
 311         (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
 312         (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
 313     (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
 314             time-low time-mid time-hi clock-seq node)))
 315
 316 (define %uuid-rx
 317   ;; The regexp of a UUID.
 318   (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
 319
 320 (define (string->uuid str)
 321   "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
 322 return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
 323 UUID representation."
 324   (and=> (regexp-exec %uuid-rx str)
 325          (lambda (match)
 326            (letrec-syntax ((hex->number
 327                             (syntax-rules ()
 328                               ((_ index)
 329                                (string->number (match:substring match index)
 330                                                16))))
 331                            (put!
 332                             (syntax-rules ()
 333                               ((_ bv index (number len) rest ...)
 334                                (begin
 335                                  (bytevector-uint-set! bv index number
 336                                                        (endianness big) len)
 337                                  (put! bv (+ index len) rest ...)))
 338                               ((_ bv index)
 339                                bv))))
 340              (let ((time-low  (hex->number 1))
 341                    (time-mid  (hex->number 2))
 342                    (time-hi   (hex->number 3))
 343                    (clock-seq (hex->number 4))
 344                    (node      (hex->number 5))
 345                    (uuid      (make-bytevector 16)))
 346                (put! uuid 0
 347                      (time-low 4) (time-mid 2) (time-hi 2)
 348                      (clock-seq 2) (node 6)))))))
 349
 350 \f
 351 (define* (canonicalize-device-spec spec #:optional (title 'any))
 352   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
 353 the following:
 354
 355   • 'device', in which case SPEC is known to designate a device node--e.g.,
 356      \"/dev/sda1\";
 357   • 'label', in which case SPEC is known to designate a partition label--e.g.,
 358      \"my-root-part\";
 359   • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
 360      designating a partition;
 361   • 'any', in which case SPEC can be anything.
 362 "
 363   (define max-trials
 364     ;; Number of times we retry partition label resolution, 1 second per
 365     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
 366     ;; USB key would be detected by the kernel, so we must wait for at least
 367     ;; this long.
 368     20)
 369
 370   (define canonical-title
 371     ;; The realm of canonicalization.
 372     (if (eq? title 'any)
 373         (if (string? spec)
 374             ;; The "--root=SPEC" kernel command-line option always provides a
 375             ;; string, but the string can represent a device, a UUID, or a
 376             ;; label.  So check for all three.
 377             (cond ((string-prefix? "/" spec) 'device)
 378                   ((string->uuid spec) 'uuid)
 379                   (else 'label))
 380             'uuid)
 381         title))
 382
 383   (define (resolve find-partition spec fmt)
 384     (let loop ((count 0))
 385       (let ((device (find-partition spec)))
 386         (or device
 387             ;; Some devices take a bit of time to appear, most notably USB
 388             ;; storage devices.  Thus, wait for the device to appear.
 389             (if (> count max-trials)
 390                 (error "failed to resolve partition" (fmt spec))
 391                 (begin
 392                   (format #t "waiting for partition '~a' to appear...~%"
 393                           (fmt spec))
 394                   (sleep 1)
 395                   (loop (+ 1 count))))))))
 396
 397   (case canonical-title
 398     ((device)
 399      ;; Nothing to do.
 400      spec)
 401     ((label)
 402      ;; Resolve the label.
 403      (resolve find-partition-by-label spec identity))
 404     ((uuid)
 405      (resolve find-partition-by-uuid
 406               (if (string? spec)
 407                   (string->uuid spec)
 408                   spec)
 409               uuid->string))
 410     (else
 411      (error "unknown device title" title))))
 412
 413 (define (check-file-system device type)
 414   "Run a file system check of TYPE on DEVICE."
 415   (define fsck
 416     (string-append "fsck." type))
 417
 418   (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
 419     (match (status:exit-val status)
 420       (0
 421        #t)
 422       (1
 423        (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
 424                fsck device))
 425       (2
 426        (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
 427                fsck device)
 428        (sleep 3)
 429        (reboot))
 430       (code
 431        (format (current-error-port) "'~a' exited with code ~a on ~a; \
 432 spawning Bourne-like REPL~%"
 433                fsck code device)
 434        (start-repl %bournish-language)))))
 435
 436 (define (mount-flags->bit-mask flags)
 437   "Return the number suitable for the 'flags' argument of 'mount' that
 438 corresponds to the symbols listed in FLAGS."
 439   (let loop ((flags flags))
 440     (match flags
 441       (('read-only rest ...)
 442        (logior MS_RDONLY (loop rest)))
 443       (('bind-mount rest ...)
 444        (logior MS_BIND (loop rest)))
 445       (('no-suid rest ...)
 446        (logior MS_NOSUID (loop rest)))
 447       (('no-dev rest ...)
 448        (logior MS_NODEV (loop rest)))
 449       (('no-exec rest ...)
 450        (logior MS_NOEXEC (loop rest)))
 451       (()
 452        0))))
 453
 454 (define (regular-file? file-name)
 455   "Return #t if FILE-NAME is a regular file."
 456   (eq? (stat:type (stat file-name)) 'regular))
 457
 458 (define* (mount-file-system spec #:key (root "/root"))
 459   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 460 form:
 461
 462   (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 463
 464 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 465 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 466 run a file system check."
 467   (match spec
 468     ((source title mount-point type (flags ...) options check?)
 469      (let ((source      (canonicalize-device-spec source title))
 470            (mount-point (string-append root "/" mount-point))
 471            (flags       (mount-flags->bit-mask flags)))
 472        (when check?
 473          (check-file-system source type))
 474
 475        ;; Create the mount point.  Most of the time this is a directory, but
 476        ;; in the case of a bind mount, a regular file may be needed.
 477        (if (and (= MS_BIND (logand flags MS_BIND))
 478                 (regular-file? source))
 479            (unless (file-exists? mount-point)
 480              (mkdir-p (dirname mount-point))
 481              (call-with-output-file mount-point (const #t)))
 482            (mkdir-p mount-point))
 483
 484        (mount source mount-point type flags options)
 485
 486        ;; For read-only bind mounts, an extra remount is needed, as per
 487        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
 488        (when (and (= MS_BIND (logand flags MS_BIND))
 489                   (= MS_RDONLY (logand flags MS_RDONLY)))
 490          (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
 491            (mount source mount-point type flags #f)))))))
 492
 493 ;;; file-systems.scm ends here