Commit | Line | Data |
---|---|---|
e2f4b305 LC |
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 | ||
4359378a | 236 | (let ((status (system* fsck "-v" "-p" "-C" "0" device))) |
e2f4b305 LC |
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) | |
9331ba5d | 290 | %null-pointer)))))) |
e2f4b305 LC |
291 | |
292 | ;;; file-systems.scm ends here |