Commit | Line | Data |
---|---|---|
0f41c26f | 1 | ;;; GNU Guix --- Functional package management for GNU |
aa27b560 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
0f41c26f LC |
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 (guix serialization) | |
20 | #:use-module (guix utils) | |
21 | #:use-module (rnrs bytevectors) | |
22 | #:use-module (rnrs io ports) | |
23 | #:use-module (srfi srfi-1) | |
24 | #:use-module (srfi srfi-26) | |
0363991a LC |
25 | #:use-module (srfi srfi-34) |
26 | #:use-module (srfi srfi-35) | |
6c20d1d0 | 27 | #:use-module (ice-9 match) |
0363991a | 28 | #:use-module (ice-9 ftw) |
0f41c26f LC |
29 | #:export (write-int read-int |
30 | write-long-long read-long-long | |
31 | write-padding | |
32 | write-string read-string read-latin1-string | |
33 | write-string-list read-string-list | |
6c20d1d0 | 34 | write-string-pairs |
0f41c26f | 35 | write-store-path read-store-path |
0363991a LC |
36 | write-store-path-list read-store-path-list |
37 | ||
38 | &nar-error | |
39 | nar-error? | |
40 | nar-error-port | |
41 | nar-error-file | |
42 | ||
43 | &nar-read-error | |
44 | nar-read-error? | |
45 | nar-read-error-token | |
46 | ||
47 | write-file | |
48 | restore-file)) | |
0f41c26f LC |
49 | |
50 | ;;; Comment: | |
51 | ;;; | |
52 | ;;; Serialization procedures used by the RPCs and the Nar format. This module | |
53 | ;;; is for internal consumption. | |
54 | ;;; | |
55 | ;;; Code: | |
56 | ||
57 | ;; Similar to serialize.cc in Nix. | |
58 | ||
46b8aadb LC |
59 | (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? |
60 | nar-error? | |
61 | (file nar-error-file) ; file we were restoring, or #f | |
62 | (port nar-error-port)) ; port from which we read | |
63 | ||
64 | (define currently-restored-file | |
65 | ;; Name of the file being restored. Used internally for error reporting. | |
66 | (make-parameter #f)) | |
67 | ||
68 | ||
69 | (define (get-bytevector-n* port count) | |
70 | (let ((bv (get-bytevector-n port count))) | |
71 | (when (or (eof-object? bv) | |
72 | (< (bytevector-length bv) count)) | |
73 | (raise (condition (&nar-error | |
74 | (file (currently-restored-file)) | |
75 | (port port))))) | |
76 | bv)) | |
77 | ||
0f41c26f LC |
78 | (define (write-int n p) |
79 | (let ((b (make-bytevector 8 0))) | |
80 | (bytevector-u32-set! b 0 n (endianness little)) | |
81 | (put-bytevector p b))) | |
82 | ||
83 | (define (read-int p) | |
46b8aadb | 84 | (let ((b (get-bytevector-n* p 8))) |
0f41c26f LC |
85 | (bytevector-u32-ref b 0 (endianness little)))) |
86 | ||
87 | (define (write-long-long n p) | |
88 | (let ((b (make-bytevector 8 0))) | |
89 | (bytevector-u64-set! b 0 n (endianness little)) | |
90 | (put-bytevector p b))) | |
91 | ||
92 | (define (read-long-long p) | |
46b8aadb | 93 | (let ((b (get-bytevector-n* p 8))) |
0f41c26f LC |
94 | (bytevector-u64-ref b 0 (endianness little)))) |
95 | ||
96 | (define write-padding | |
97 | (let ((zero (make-bytevector 8 0))) | |
98 | (lambda (n p) | |
99 | (let ((m (modulo n 8))) | |
100 | (or (zero? m) | |
101 | (put-bytevector p zero 0 (- 8 m))))))) | |
102 | ||
103 | (define (write-string s p) | |
104 | (let* ((s (string->utf8 s)) | |
105 | (l (bytevector-length s)) | |
106 | (m (modulo l 8)) | |
107 | (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) | |
108 | (bytevector-u32-set! b 0 l (endianness little)) | |
109 | (bytevector-copy! s 0 b 8 l) | |
110 | (put-bytevector p b))) | |
111 | ||
112 | (define (read-string p) | |
113 | (let* ((len (read-int p)) | |
114 | (m (modulo len 8)) | |
46b8aadb | 115 | (bv (get-bytevector-n* p len)) |
0f41c26f LC |
116 | (str (utf8->string bv))) |
117 | (or (zero? m) | |
46b8aadb | 118 | (get-bytevector-n* p (- 8 m))) |
0f41c26f LC |
119 | str)) |
120 | ||
121 | (define (read-latin1-string p) | |
122 | (let* ((len (read-int p)) | |
123 | (m (modulo len 8)) | |
aa27b560 LC |
124 | ;; Note: do not use 'get-string-n' to work around Guile bug |
125 | ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for | |
126 | ;; a discussion. | |
46b8aadb | 127 | (str (get-bytevector-n* p len))) |
0f41c26f | 128 | (or (zero? m) |
46b8aadb | 129 | (get-bytevector-n* p (- 8 m))) |
aa27b560 LC |
130 | |
131 | ;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is | |
132 | ;; upgraded to Guile >= 2.0.9. | |
133 | (list->string (map integer->char (bytevector->u8-list str))))) | |
0f41c26f LC |
134 | |
135 | (define (write-string-list l p) | |
136 | (write-int (length l) p) | |
137 | (for-each (cut write-string <> p) l)) | |
138 | ||
6c20d1d0 LC |
139 | (define (write-string-pairs l p) |
140 | (write-int (length l) p) | |
141 | (for-each (match-lambda | |
142 | ((first . second) | |
143 | (write-string first p) | |
144 | (write-string second p))) | |
145 | l)) | |
146 | ||
0f41c26f LC |
147 | (define (read-string-list p) |
148 | (let ((len (read-int p))) | |
149 | (unfold (cut >= <> len) | |
150 | (lambda (i) | |
151 | (read-string p)) | |
152 | 1+ | |
153 | 0))) | |
154 | ||
155 | (define (write-store-path f p) | |
156 | (write-string f p)) ; TODO: assert path | |
157 | ||
158 | (define (read-store-path p) | |
159 | (read-string p)) ; TODO: assert path | |
160 | ||
161 | (define write-store-path-list write-string-list) | |
162 | (define read-store-path-list read-string-list) | |
163 | ||
0363991a | 164 | \f |
0363991a LC |
165 | (define-condition-type &nar-read-error &nar-error |
166 | nar-read-error? | |
167 | (token nar-read-error-token)) ; faulty token, or #f | |
168 | ||
169 | ||
170 | (define (dump in out size) | |
171 | "Copy SIZE bytes from IN to OUT." | |
172 | (define buf-size 65536) | |
173 | (define buf (make-bytevector buf-size)) | |
174 | ||
175 | (let loop ((left size)) | |
176 | (if (<= left 0) | |
177 | 0 | |
178 | (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) | |
179 | (if (eof-object? read) | |
180 | left | |
181 | (begin | |
182 | (put-bytevector out buf 0 read) | |
183 | (loop (- left read)))))))) | |
184 | ||
185 | (define (write-contents file p size) | |
186 | "Write SIZE bytes from FILE to output port P." | |
187 | (define (call-with-binary-input-file file proc) | |
188 | ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus | |
189 | ;; avoids any initial buffering. Disable file name canonicalization to | |
190 | ;; avoid stat'ing like crazy. | |
191 | (with-fluids ((%file-port-name-canonicalization #f)) | |
192 | (let ((port (open-file file "rb"))) | |
193 | (dynamic-wind | |
194 | (const #t) | |
195 | (cut proc port) | |
196 | (lambda () | |
197 | (close-port port)))))) | |
198 | ||
199 | (write-string "contents" p) | |
200 | (write-long-long size p) | |
201 | (call-with-binary-input-file file | |
202 | ;; Use `sendfile' when available (Guile 2.0.8+). | |
203 | (if (and (compile-time-value (defined? 'sendfile)) | |
204 | (file-port? p)) | |
205 | (cut sendfile p <> size 0) | |
206 | (cut dump <> p size))) | |
207 | (write-padding size p)) | |
208 | ||
209 | (define (read-contents in out) | |
210 | "Read the contents of a file from the Nar at IN, write it to OUT, and return | |
211 | the size in bytes." | |
212 | (define executable? | |
213 | (match (read-string in) | |
214 | ("contents" | |
215 | #f) | |
216 | ("executable" | |
217 | (match (list (read-string in) (read-string in)) | |
218 | (("" "contents") #t) | |
219 | (x (raise | |
220 | (condition (&message | |
221 | (message "unexpected executable file marker")) | |
222 | (&nar-read-error (port in) | |
223 | (file #f) | |
224 | (token x)))))) | |
225 | #t) | |
226 | (x | |
227 | (raise | |
228 | (condition (&message (message "unsupported nar file type")) | |
229 | (&nar-read-error (port in) (file #f) (token x))))))) | |
230 | ||
231 | (let ((size (read-long-long in))) | |
232 | ;; Note: `sendfile' cannot be used here because of port buffering on IN. | |
233 | (dump in out size) | |
234 | ||
235 | (when executable? | |
236 | (chmod out #o755)) | |
237 | (let ((m (modulo size 8))) | |
238 | (unless (zero? m) | |
46b8aadb | 239 | (get-bytevector-n* in (- 8 m)))) |
0363991a LC |
240 | size)) |
241 | ||
242 | (define %archive-version-1 | |
243 | ;; Magic cookie for Nix archives. | |
244 | "nix-archive-1") | |
245 | ||
246 | (define (write-file file port) | |
247 | "Write the contents of FILE to PORT in Nar format, recursing into | |
248 | sub-directories of FILE as needed." | |
249 | (define p port) | |
250 | ||
251 | (write-string %archive-version-1 p) | |
252 | ||
253 | (let dump ((f file)) | |
254 | (let ((s (lstat f))) | |
255 | (write-string "(" p) | |
256 | (case (stat:type s) | |
257 | ((regular) | |
258 | (write-string "type" p) | |
259 | (write-string "regular" p) | |
260 | (if (not (zero? (logand (stat:mode s) #o100))) | |
261 | (begin | |
262 | (write-string "executable" p) | |
263 | (write-string "" p))) | |
264 | (write-contents f p (stat:size s))) | |
265 | ((directory) | |
266 | (write-string "type" p) | |
267 | (write-string "directory" p) | |
268 | (let ((entries | |
269 | ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories | |
270 | ;; unconditionally, including "." and "..", regardless of the | |
271 | ;; 'select?' predicate passed to it, so we have to filter | |
272 | ;; those out externally. | |
273 | (filter (negate (cut member <> '("." ".."))) | |
274 | ;; 'scandir' defaults to 'string-locale<?' to sort | |
275 | ;; files, but this happens to be case-insensitive (at | |
276 | ;; least in 'en_US' locale on libc 2.18.) Conversely, | |
277 | ;; we want files to be sorted in a case-sensitive | |
278 | ;; fashion. | |
279 | (scandir f (const #t) string<?)))) | |
280 | (for-each (lambda (e) | |
281 | (let ((f (string-append f "/" e))) | |
282 | (write-string "entry" p) | |
283 | (write-string "(" p) | |
284 | (write-string "name" p) | |
285 | (write-string e p) | |
286 | (write-string "node" p) | |
287 | (dump f) | |
288 | (write-string ")" p))) | |
289 | entries))) | |
290 | ((symlink) | |
291 | (write-string "type" p) | |
292 | (write-string "symlink" p) | |
293 | (write-string "target" p) | |
294 | (write-string (readlink f) p)) | |
295 | (else | |
296 | (raise (condition (&message (message "unsupported file type")) | |
297 | (&nar-error (file f) (port port)))))) | |
298 | (write-string ")" p)))) | |
299 | ||
300 | (define (restore-file port file) | |
301 | "Read a file (possibly a directory structure) in Nar format from PORT. | |
302 | Restore it as FILE." | |
46b8aadb LC |
303 | (parameterize ((currently-restored-file file)) |
304 | (let ((signature (read-string port))) | |
305 | (unless (equal? signature %archive-version-1) | |
306 | (raise | |
307 | (condition (&message (message "invalid nar signature")) | |
308 | (&nar-read-error (port port) | |
309 | (token signature) | |
310 | (file #f)))))) | |
311 | ||
312 | (let restore ((file file)) | |
313 | (define (read-eof-marker) | |
314 | (match (read-string port) | |
315 | (")" #t) | |
316 | (x (raise | |
317 | (condition | |
318 | (&message (message "invalid nar end-of-file marker")) | |
319 | (&nar-read-error (port port) (file file) (token x))))))) | |
320 | ||
321 | (currently-restored-file file) | |
322 | ||
323 | (match (list (read-string port) (read-string port) (read-string port)) | |
324 | (("(" "type" "regular") | |
325 | (call-with-output-file file (cut read-contents port <>)) | |
326 | (read-eof-marker)) | |
327 | (("(" "type" "symlink") | |
328 | (match (list (read-string port) (read-string port)) | |
329 | (("target" target) | |
330 | (symlink target file) | |
331 | (read-eof-marker)) | |
332 | (x (raise | |
0363991a | 333 | (condition |
46b8aadb LC |
334 | (&message (message "invalid symlink tokens")) |
335 | (&nar-read-error (port port) (file file) (token x))))))) | |
336 | (("(" "type" "directory") | |
337 | (let ((dir file)) | |
338 | (mkdir dir) | |
339 | (let loop ((prefix (read-string port))) | |
340 | (match prefix | |
341 | ("entry" | |
342 | (match (list (read-string port) | |
343 | (read-string port) (read-string port) | |
344 | (read-string port)) | |
345 | (("(" "name" file "node") | |
346 | (restore (string-append dir "/" file)) | |
347 | (match (read-string port) | |
348 | (")" #t) | |
349 | (x | |
350 | (raise | |
351 | (condition | |
352 | (&message | |
353 | (message "unexpected directory entry termination")) | |
354 | (&nar-read-error (port port) | |
355 | (file file) | |
356 | (token x)))))) | |
357 | (loop (read-string port))))) | |
358 | (")" #t) ; done with DIR | |
359 | (x | |
360 | (raise | |
361 | (condition | |
362 | (&message (message "unexpected directory inter-entry marker")) | |
363 | (&nar-read-error (port port) (file file) (token x))))))))) | |
364 | (x | |
365 | (raise | |
366 | (condition | |
367 | (&message (message "unsupported nar entry type")) | |
368 | (&nar-read-error (port port) (file file) (token x))))))))) | |
0363991a | 369 | |
0f41c26f | 370 | ;;; serialization.scm ends here |