diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-09-03 14:19:51 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2014-09-03 15:43:07 +0200 |
| commit | e2f4b305d0b7cff1e19c7f67ea633ef8a971e712 (patch) | |
| tree | 65302d216abc0b0811e4beb41179f586abe01a41 | |
| parent | 8a9e21d1f719748213414343cd02ec113ebe90c1 (diff) | |
Move part of (gnu build linux-boot) to (gnu build file-systems).
* gnu/build/linux-boot.scm (%ext2-endianness, %ext2-sblock-magic,
%ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name,
read-ext2-superblock, ext2-superblock-uuid,
ext2-superblock-volume-name, disk-partitions,
partition-label-predicate, find-partition-by-label,
canonicalize-device-spec, MS_RDONLY, MS_NOSUID, MS_NODEV, MS_NOEXEC,
MS_BIND, MS_MOVE, bind-mount, check-file-system,
mount-flags->bit-mask, mount-file-system): Move to...
* gnu/build/file-systems.scm: ... here. New file.
* gnu-system.am (GNU_SYSTEM_MODULES): Add it.
* gnu/services/base.scm: Use (gnu build file-systems).
* gnu/services/dmd.scm (dmd-configuration-file): Likewise.
* gnu/system.scm (operating-system-activation-script): Likewise.
* gnu/system/linux-initrd.scm (base-initrd): Likewise.
* gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise.
| -rw-r--r-- | gnu-system.am | 1 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 299 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 259 | ||||
| -rw-r--r-- | gnu/services/base.scm | 2 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 4 | ||||
| -rw-r--r-- | gnu/system.scm | 1 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 3 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 1 |
8 files changed, 308 insertions, 262 deletions
diff --git a/gnu-system.am b/gnu-system.am index 8e7de7c622c..d4f27314c20 100644 --- a/gnu-system.am +++ b/gnu-system.am | |||
| @@ -280,6 +280,7 @@ GNU_SYSTEM_MODULES = \ | |||
| 280 | gnu/system/vm.scm \ | 280 | gnu/system/vm.scm \ |
| 281 | \ | 281 | \ |
| 282 | gnu/build/activation.scm \ | 282 | gnu/build/activation.scm \ |
| 283 | gnu/build/file-systems.scm \ | ||
| 283 | gnu/build/install.scm \ | 284 | gnu/build/install.scm \ |
| 284 | gnu/build/linux-boot.scm \ | 285 | gnu/build/linux-boot.scm \ |
| 285 | gnu/build/vm.scm | 286 | gnu/build/vm.scm |
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm new file mode 100644 index 00000000000..5c04771e192 --- /dev/null +++ b/gnu/build/file-systems.scm | |||
| @@ -0,0 +1,299 @@ | |||
| 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" 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 | ;; Update /etc/mtab. | ||
| 293 | (mkdir-p (string-append root "/etc")) | ||
| 294 | (let ((port (open-file (string-append root "/etc/mtab") "a"))) | ||
| 295 | (format port "~a ~a ~a ~a 0 0~%" | ||
| 296 | source mount-point type (or options "")) | ||
| 297 | (close-port port)))))) | ||
| 298 | |||
| 299 | ;;; file-systems.scm ends here | ||
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 24000e191a7..21ee58ad506 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm | |||
| @@ -18,33 +18,22 @@ | |||
| 18 | 18 | ||
| 19 | (define-module (gnu build linux-boot) | 19 | (define-module (gnu build linux-boot) |
| 20 | #:use-module (rnrs io ports) | 20 | #:use-module (rnrs io ports) |
| 21 | #:use-module (rnrs bytevectors) | ||
| 22 | #:use-module (system foreign) | ||
| 23 | #:use-module (system repl error-handling) | 21 | #:use-module (system repl error-handling) |
| 24 | #:autoload (system repl repl) (start-repl) | 22 | #:autoload (system repl repl) (start-repl) |
| 25 | #:autoload (system base compile) (compile-file) | 23 | #:autoload (system base compile) (compile-file) |
| 26 | #:use-module (srfi srfi-1) | 24 | #:use-module (srfi srfi-1) |
| 27 | #:use-module (srfi srfi-26) | 25 | #:use-module (srfi srfi-26) |
| 28 | #:use-module (ice-9 match) | 26 | #:use-module (ice-9 match) |
| 29 | #:use-module (ice-9 rdelim) | ||
| 30 | #:use-module (ice-9 ftw) | 27 | #:use-module (ice-9 ftw) |
| 31 | #:use-module (guix build utils) | 28 | #:use-module (guix build utils) |
| 29 | #:use-module (gnu build file-systems) | ||
| 32 | #:export (mount-essential-file-systems | 30 | #:export (mount-essential-file-systems |
| 33 | linux-command-line | 31 | linux-command-line |
| 34 | find-long-option | 32 | find-long-option |
| 35 | make-essential-device-nodes | 33 | make-essential-device-nodes |
| 36 | configure-qemu-networking | 34 | configure-qemu-networking |
| 37 | 35 | ||
| 38 | disk-partitions | ||
| 39 | partition-label-predicate | ||
| 40 | find-partition-by-label | ||
| 41 | canonicalize-device-spec | ||
| 42 | |||
| 43 | mount-flags->bit-mask | ||
| 44 | check-file-system | ||
| 45 | mount-file-system | ||
| 46 | bind-mount | 36 | bind-mount |
| 47 | |||
| 48 | load-linux-module* | 37 | load-linux-module* |
| 49 | device-number | 38 | device-number |
| 50 | boot-system)) | 39 | boot-system)) |
| @@ -99,172 +88,6 @@ Return the value associated with OPTION, or #f on failure." | |||
| 99 | (lambda (arg) | 88 | (lambda (arg) |
| 100 | (substring arg (+ 1 (string-index arg #\=))))))) | 89 | (substring arg (+ 1 (string-index arg #\=))))))) |
| 101 | 90 | ||
| 102 | (define-syntax %ext2-endianness | ||
| 103 | ;; Endianness of ext2 file systems. | ||
| 104 | (identifier-syntax (endianness little))) | ||
| 105 | |||
| 106 | ;; Offset in bytes of interesting parts of an ext2 superblock. See | ||
| 107 | ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>. | ||
| 108 | ;; TODO: Use "packed structs" from Guile-OpenGL or similar. | ||
| 109 | (define-syntax %ext2-sblock-magic (identifier-syntax 56)) | ||
| 110 | (define-syntax %ext2-sblock-creator-os (identifier-syntax 72)) | ||
| 111 | (define-syntax %ext2-sblock-uuid (identifier-syntax 104)) | ||
| 112 | (define-syntax %ext2-sblock-volume-name (identifier-syntax 120)) | ||
| 113 | |||
| 114 | (define (read-ext2-superblock device) | ||
| 115 | "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f | ||
| 116 | if DEVICE does not contain an ext2 file system." | ||
| 117 | (define %ext2-magic | ||
| 118 | ;; The magic bytes that identify an ext2 file system. | ||
| 119 | #xef53) | ||
| 120 | |||
| 121 | (define superblock-size | ||
| 122 | ;; Size of the interesting part of an ext2 superblock. | ||
| 123 | 264) | ||
| 124 | |||
| 125 | (define block | ||
| 126 | ;; The superblock contents. | ||
| 127 | (make-bytevector superblock-size)) | ||
| 128 | |||
| 129 | (call-with-input-file device | ||
| 130 | (lambda (port) | ||
| 131 | (seek port 1024 SEEK_SET) | ||
| 132 | |||
| 133 | ;; Note: work around <http://bugs.gnu.org/17466>. | ||
| 134 | (and (eqv? superblock-size (get-bytevector-n! port block 0 | ||
| 135 | superblock-size)) | ||
| 136 | (let ((magic (bytevector-u16-ref block %ext2-sblock-magic | ||
| 137 | %ext2-endianness))) | ||
| 138 | (and (= magic %ext2-magic) | ||
| 139 | block)))))) | ||
| 140 | |||
| 141 | (define (ext2-superblock-uuid sblock) | ||
| 142 | "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector." | ||
| 143 | (let ((uuid (make-bytevector 16))) | ||
| 144 | (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16) | ||
| 145 | uuid)) | ||
| 146 | |||
| 147 | (define (ext2-superblock-volume-name sblock) | ||
| 148 | "Return the volume name of SBLOCK as a string of at most 16 characters, or | ||
| 149 | #f if SBLOCK has no volume name." | ||
| 150 | (let ((bv (make-bytevector 16))) | ||
| 151 | (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16) | ||
| 152 | |||
| 153 | ;; This is a Latin-1, nul-terminated string. | ||
| 154 | (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv)))) | ||
| 155 | (if (null? bytes) | ||
| 156 | #f | ||
| 157 | (list->string (map integer->char bytes)))))) | ||
| 158 | |||
| 159 | (define (disk-partitions) | ||
| 160 | "Return the list of device names corresponding to valid disk partitions." | ||
| 161 | (define (partition? major minor) | ||
| 162 | (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor))) | ||
| 163 | (catch 'system-error | ||
| 164 | (lambda () | ||
| 165 | (not (zero? (call-with-input-file marker read)))) | ||
| 166 | (lambda args | ||
| 167 | (if (= ENOENT (system-error-errno args)) | ||
| 168 | #f | ||
| 169 | (apply throw args)))))) | ||
| 170 | |||
| 171 | (call-with-input-file "/proc/partitions" | ||
| 172 | (lambda (port) | ||
| 173 | ;; Skip the two header lines. | ||
| 174 | (read-line port) | ||
| 175 | (read-line port) | ||
| 176 | |||
| 177 | ;; Read each subsequent line, and extract the last space-separated | ||
| 178 | ;; field. | ||
| 179 | (let loop ((parts '())) | ||
| 180 | (let ((line (read-line port))) | ||
| 181 | (if (eof-object? line) | ||
| 182 | (reverse parts) | ||
| 183 | (match (string-tokenize line) | ||
| 184 | (((= string->number major) (= string->number minor) | ||
| 185 | blocks name) | ||
| 186 | (if (partition? major minor) | ||
| 187 | (loop (cons name parts)) | ||
| 188 | (loop parts)))))))))) | ||
| 189 | |||
| 190 | (define (partition-label-predicate label) | ||
| 191 | "Return a procedure that, when applied to a partition name such as \"sda1\", | ||
| 192 | return #t if that partition's volume name is LABEL." | ||
| 193 | (lambda (part) | ||
| 194 | (let* ((device (string-append "/dev/" part)) | ||
| 195 | (sblock (catch 'system-error | ||
| 196 | (lambda () | ||
| 197 | (read-ext2-superblock device)) | ||
| 198 | (lambda args | ||
| 199 | ;; When running on the hand-made /dev, | ||
| 200 | ;; 'disk-partitions' could return partitions for which | ||
| 201 | ;; we have no /dev node. Handle that gracefully. | ||
| 202 | (if (= ENOENT (system-error-errno args)) | ||
| 203 | (begin | ||
| 204 | (format (current-error-port) | ||
| 205 | "warning: device '~a' not found~%" | ||
| 206 | device) | ||
| 207 | #f) | ||
| 208 | (apply throw args)))))) | ||
| 209 | (and sblock | ||
| 210 | (let ((volume (ext2-superblock-volume-name sblock))) | ||
| 211 | (and volume | ||
| 212 | (string=? volume label))))))) | ||
| 213 | |||
| 214 | (define (find-partition-by-label label) | ||
| 215 | "Return the first partition found whose volume name is LABEL, or #f if none | ||
| 216 | were found." | ||
| 217 | (and=> (find (partition-label-predicate label) | ||
| 218 | (disk-partitions)) | ||
| 219 | (cut string-append "/dev/" <>))) | ||
| 220 | |||
| 221 | (define* (canonicalize-device-spec spec #:optional (title 'any)) | ||
| 222 | "Return the device name corresponding to SPEC. TITLE is a symbol, one of | ||
| 223 | the following: | ||
| 224 | |||
| 225 | • 'device', in which case SPEC is known to designate a device node--e.g., | ||
| 226 | \"/dev/sda1\"; | ||
| 227 | • 'label', in which case SPEC is known to designate a partition label--e.g., | ||
| 228 | \"my-root-part\"; | ||
| 229 | • 'any', in which case SPEC can be anything. | ||
| 230 | " | ||
| 231 | (define max-trials | ||
| 232 | ;; Number of times we retry partition label resolution, 1 second per | ||
| 233 | ;; trial. Note: somebody reported a delay of 16 seconds (!) before their | ||
| 234 | ;; USB key would be detected by the kernel, so we must wait for at least | ||
| 235 | ;; this long. | ||
| 236 | 20) | ||
| 237 | |||
| 238 | (define canonical-title | ||
| 239 | ;; The realm of canonicalization. | ||
| 240 | (if (eq? title 'any) | ||
| 241 | (if (string-prefix? "/" spec) | ||
| 242 | 'device | ||
| 243 | 'label) | ||
| 244 | title)) | ||
| 245 | |||
| 246 | (case canonical-title | ||
| 247 | ((device) | ||
| 248 | ;; Nothing to do. | ||
| 249 | spec) | ||
| 250 | ((label) | ||
| 251 | ;; Resolve the label. | ||
| 252 | (let loop ((count 0)) | ||
| 253 | (let ((device (find-partition-by-label spec))) | ||
| 254 | (or device | ||
| 255 | ;; Some devices take a bit of time to appear, most notably USB | ||
| 256 | ;; storage devices. Thus, wait for the device to appear. | ||
| 257 | (if (> count max-trials) | ||
| 258 | (error "failed to resolve partition label" spec) | ||
| 259 | (begin | ||
| 260 | (format #t "waiting for partition '~a' to appear...~%" | ||
| 261 | spec) | ||
| 262 | (sleep 1) | ||
| 263 | (loop (+ 1 count)))))))) | ||
| 264 | ;; TODO: Add support for UUIDs. | ||
| 265 | (else | ||
| 266 | (error "unknown device title" title)))) | ||
| 267 | |||
| 268 | (define* (make-disk-device-nodes base major #:optional (minor 0)) | 91 | (define* (make-disk-device-nodes base major #:optional (minor 0)) |
| 269 | "Make the block device nodes around BASE (something like \"/root/dev/sda\") | 92 | "Make the block device nodes around BASE (something like \"/root/dev/sda\") |
| 270 | with the given MAJOR number, starting with MINOR." | 93 | with the given MAJOR number, starting with MINOR." |
| @@ -395,18 +218,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." | |||
| 395 | 218 | ||
| 396 | (logand (network-interface-flags sock interface) IFF_UP))) | 219 | (logand (network-interface-flags sock interface) IFF_UP))) |
| 397 | 220 | ||
| 398 | ;; Linux mount flags, from libc's <sys/mount.h>. | ||
| 399 | (define MS_RDONLY 1) | ||
| 400 | (define MS_NOSUID 2) | ||
| 401 | (define MS_NODEV 4) | ||
| 402 | (define MS_NOEXEC 8) | ||
| 403 | (define MS_BIND 4096) | ||
| 404 | (define MS_MOVE 8192) | ||
| 405 | |||
| 406 | (define (bind-mount source target) | ||
| 407 | "Bind-mount SOURCE at TARGET." | ||
| 408 | (mount source target "" MS_BIND)) | ||
| 409 | |||
| 410 | (define (load-linux-module* file) | 221 | (define (load-linux-module* file) |
| 411 | "Load Linux module from FILE, the name of a `.ko' file." | 222 | "Load Linux module from FILE, the name of a `.ko' file." |
| 412 | (define (slurp module) | 223 | (define (slurp module) |
| @@ -479,74 +290,6 @@ UNIONFS." | |||
| 479 | 290 | ||
| 480 | (copy-file "/proc/mounts" "/root/etc/mtab")) | 291 | (copy-file "/proc/mounts" "/root/etc/mtab")) |
| 481 | 292 | ||
| 482 | (define (check-file-system device type) | ||
| 483 | "Run a file system check of TYPE on DEVICE." | ||
| 484 | (define fsck | ||
| 485 | (string-append "fsck." type)) | ||
| 486 | |||
| 487 | (let ((status (system* fsck "-v" "-p" device))) | ||
| 488 | (match (status:exit-val status) | ||
| 489 | (0 | ||
| 490 | #t) | ||
| 491 | (1 | ||
| 492 | (format (current-error-port) "'~a' corrected errors on ~a; continuing~%" | ||
| 493 | fsck device)) | ||
| 494 | (2 | ||
| 495 | (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%" | ||
| 496 | fsck device) | ||
| 497 | (sleep 3) | ||
| 498 | (reboot)) | ||
| 499 | (code | ||
| 500 | (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%" | ||
| 501 | fsck code device) | ||
| 502 | (start-repl))))) | ||
| 503 | |||
| 504 | (define (mount-flags->bit-mask flags) | ||
| 505 | "Return the number suitable for the 'flags' argument of 'mount' that | ||
| 506 | corresponds to the symbols listed in FLAGS." | ||
| 507 | (let loop ((flags flags)) | ||
| 508 | (match flags | ||
| 509 | (('read-only rest ...) | ||
| 510 | (logior MS_RDONLY (loop rest))) | ||
| 511 | (('bind-mount rest ...) | ||
| 512 | (logior MS_BIND (loop rest))) | ||
| 513 | (('no-suid rest ...) | ||
| 514 | (logior MS_NOSUID (loop rest))) | ||
| 515 | (('no-dev rest ...) | ||
| 516 | (logior MS_NODEV (loop rest))) | ||
| 517 | (('no-exec rest ...) | ||
| 518 | (logior MS_NOEXEC (loop rest))) | ||
| 519 | (() | ||
| 520 | 0)))) | ||
| 521 | |||
| 522 | (define* (mount-file-system spec #:key (root "/root")) | ||
| 523 | "Mount the file system described by SPEC under ROOT. SPEC must have the | ||
| 524 | form: | ||
| 525 | |||
| 526 | (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) | ||
| 527 | |||
| 528 | DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; | ||
| 529 | FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to | ||
| 530 | run a file system check." | ||
| 531 | (match spec | ||
| 532 | ((source title mount-point type (flags ...) options check?) | ||
| 533 | (let ((source (canonicalize-device-spec source title)) | ||
| 534 | (mount-point (string-append root "/" mount-point))) | ||
| 535 | (when check? | ||
| 536 | (check-file-system source type)) | ||
| 537 | (mkdir-p mount-point) | ||
| 538 | (mount source mount-point type (mount-flags->bit-mask flags) | ||
| 539 | (if options | ||
| 540 | (string->pointer options) | ||
| 541 | %null-pointer)) | ||
| 542 | |||
| 543 | ;; Update /etc/mtab. | ||
| 544 | (mkdir-p (string-append root "/etc")) | ||
| 545 | (let ((port (open-file (string-append root "/etc/mtab") "a"))) | ||
| 546 | (format port "~a ~a ~a ~a 0 0~%" | ||
| 547 | source mount-point type (or options "")) | ||
| 548 | (close-port port)))))) | ||
| 549 | |||
| 550 | (define (switch-root root) | 293 | (define (switch-root root) |
| 551 | "Switch to ROOT as the root file system, in a way similar to what | 294 | "Switch to ROOT as the root file system, in a way similar to what |
| 552 | util-linux' switch_root(8) does." | 295 | util-linux' switch_root(8) does." |
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e9adb47ac02..b5b49d1a01b 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm | |||
| @@ -29,7 +29,7 @@ | |||
| 29 | #:use-module ((gnu packages base) | 29 | #:use-module ((gnu packages base) |
| 30 | #:select (canonical-package glibc)) | 30 | #:select (canonical-package glibc)) |
| 31 | #:use-module (gnu packages package-management) | 31 | #:use-module (gnu packages package-management) |
| 32 | #:use-module ((gnu build linux-boot) | 32 | #:use-module ((gnu build file-systems) |
| 33 | #:select (mount-flags->bit-mask)) | 33 | #:select (mount-flags->bit-mask)) |
| 34 | #:use-module (guix gexp) | 34 | #:use-module (guix gexp) |
| 35 | #:use-module (guix monads) | 35 | #:use-module (guix monads) |
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index d1fa58f9d78..59c23737798 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm | |||
| @@ -35,7 +35,7 @@ | |||
| 35 | (define modules | 35 | (define modules |
| 36 | ;; Extra modules visible to dmd.conf. | 36 | ;; Extra modules visible to dmd.conf. |
| 37 | '((guix build syscalls) | 37 | '((guix build syscalls) |
| 38 | (gnu build linux-boot) | 38 | (gnu build file-systems) |
| 39 | (guix build utils))) | 39 | (guix build utils))) |
| 40 | 40 | ||
| 41 | (mlet %store-monad ((modules (imported-modules modules)) | 41 | (mlet %store-monad ((modules (imported-modules modules)) |
| @@ -50,7 +50,7 @@ | |||
| 50 | (use-modules (ice-9 ftw) | 50 | (use-modules (ice-9 ftw) |
| 51 | (guix build syscalls) | 51 | (guix build syscalls) |
| 52 | (guix build utils) | 52 | (guix build utils) |
| 53 | ((gnu build linux-boot) | 53 | ((gnu build file-systems) |
| 54 | #:select (check-file-system canonicalize-device-spec))) | 54 | #:select (check-file-system canonicalize-device-spec))) |
| 55 | 55 | ||
| 56 | (register-services | 56 | (register-services |
diff --git a/gnu/system.scm b/gnu/system.scm index e011a00f163..ea7fdf1cb78 100644 --- a/gnu/system.scm +++ b/gnu/system.scm | |||
| @@ -364,6 +364,7 @@ etc." | |||
| 364 | (define %modules | 364 | (define %modules |
| 365 | '((gnu build activation) | 365 | '((gnu build activation) |
| 366 | (gnu build linux-boot) | 366 | (gnu build linux-boot) |
| 367 | (gnu build file-systems) | ||
| 367 | (guix build utils))) | 368 | (guix build utils))) |
| 368 | 369 | ||
| 369 | (define (service-activations services) | 370 | (define (service-activations services) |
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 93c739c99e0..c4ab73ec9a2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm | |||
| @@ -293,7 +293,8 @@ exception and backtrace!)." | |||
| 293 | #:volatile-root? '#$volatile-root?)) | 293 | #:volatile-root? '#$volatile-root?)) |
| 294 | #:name "base-initrd" | 294 | #:name "base-initrd" |
| 295 | #:modules '((guix build utils) | 295 | #:modules '((guix build utils) |
| 296 | (gnu build linux-boot)) | 296 | (gnu build linux-boot) |
| 297 | (gnu build file-systems)) | ||
| 297 | #:to-copy helper-packages | 298 | #:to-copy helper-packages |
| 298 | #:linux linux-libre | 299 | #:linux linux-libre |
| 299 | #:linux-modules linux-modules)) | 300 | #:linux-modules linux-modules)) |
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 3e26dfb700f..d263edb4f1a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm | |||
| @@ -115,6 +115,7 @@ input tuple. The output file name is when building for SYSTEM." | |||
| 115 | '((gnu build vm) | 115 | '((gnu build vm) |
| 116 | (gnu build install) | 116 | (gnu build install) |
| 117 | (gnu build linux-boot) | 117 | (gnu build linux-boot) |
| 118 | (gnu build file-systems) | ||
| 118 | (guix build utils))) | 119 | (guix build utils))) |
| 119 | (guile-for-build | 120 | (guile-for-build |
| 120 | (%guile-for-build)) | 121 | (%guile-for-build)) |
