Commit | Line | Data |
---|---|---|
0f41c26f LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012, 2013 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 (guix nar) | |
20 | #:use-module (guix utils) | |
21 | #:use-module (guix serialization) | |
53c63ee9 | 22 | #:use-module ((guix build utils) #:select (with-directory-excursion)) |
0f41c26f LC |
23 | #:use-module (rnrs bytevectors) |
24 | #:use-module (rnrs io ports) | |
25 | #:use-module (srfi srfi-1) | |
26 | #:use-module (srfi srfi-26) | |
53c63ee9 LC |
27 | #:use-module (srfi srfi-34) |
28 | #:use-module (srfi srfi-35) | |
0f41c26f | 29 | #:use-module (ice-9 ftw) |
53c63ee9 LC |
30 | #:use-module (ice-9 match) |
31 | #:export (nar-error? | |
32 | nar-read-error? | |
33 | nar-read-error-file | |
34 | nar-read-error-port | |
35 | nar-read-error-token | |
36 | ||
37 | write-file | |
38 | restore-file)) | |
0f41c26f LC |
39 | |
40 | ;;; Comment: | |
41 | ;;; | |
42 | ;;; Read and write Nix archives, aka. ‘nar’. | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
53c63ee9 LC |
46 | (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? |
47 | nar-error?) | |
48 | ||
49 | (define-condition-type &nar-read-error &nar-error | |
50 | nar-read-error? | |
51 | (port nar-read-error-port) ; port from which we read | |
52 | (file nar-read-error-file) ; file we were restoring, or #f | |
53 | (token nar-read-error-token)) ; faulty token, or #f | |
54 | ||
55 | ||
56 | (define (dump in out size) | |
57 | "Copy SIZE bytes from IN to OUT." | |
58 | (define buf-size 65536) | |
59 | (define buf (make-bytevector buf-size)) | |
60 | ||
61 | (let loop ((left size)) | |
62 | (if (<= left 0) | |
63 | 0 | |
64 | (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) | |
65 | (if (eof-object? read) | |
66 | left | |
67 | (begin | |
68 | (put-bytevector out buf 0 read) | |
69 | (loop (- left read)))))))) | |
70 | ||
0f41c26f LC |
71 | (define (write-contents file p size) |
72 | "Write SIZE bytes from FILE to output port P." | |
73 | (define (call-with-binary-input-file file proc) | |
74 | ;; Open FILE as a binary file. This avoids scan-for-encoding, and thus | |
75 | ;; avoids any initial buffering. Disable file name canonicalization to | |
76 | ;; avoid stat'ing like crazy. | |
77 | (with-fluids ((%file-port-name-canonicalization #f)) | |
78 | (let ((port (open-file file "rb"))) | |
48e488eb LC |
79 | (dynamic-wind |
80 | (const #t) | |
81 | (cut proc port) | |
82 | (lambda () | |
83 | (close-port port)))))) | |
0f41c26f | 84 | |
0f41c26f LC |
85 | (write-string "contents" p) |
86 | (write-long-long size p) | |
87 | (call-with-binary-input-file file | |
88 | ;; Use `sendfile' when available (Guile 2.0.8+). | |
89 | (if (compile-time-value (defined? 'sendfile)) | |
90 | (cut sendfile p <> size 0) | |
53c63ee9 | 91 | (cut dump <> p size))) |
0f41c26f LC |
92 | (write-padding size p)) |
93 | ||
53c63ee9 LC |
94 | (define (read-contents in out) |
95 | "Read the contents of a file from the Nar at IN, write it to OUT, and return | |
96 | the size in bytes." | |
97 | (define executable? | |
98 | (match (read-string in) | |
99 | ("contents" | |
100 | #f) | |
101 | ("executable" | |
102 | (match (list (read-string in) (read-string in)) | |
103 | (("" "contents") #t) | |
104 | (x (raise | |
105 | (condition (&message | |
106 | (message "unexpected executable file marker")) | |
107 | (&nar-read-error (port in) | |
108 | (file #f) | |
109 | (token x)))))) | |
110 | #t) | |
111 | (x | |
112 | (raise | |
113 | (condition (&message (message "unsupported nar file type")) | |
114 | (&nar-read-error (port in) (file #f) (token x))))))) | |
115 | ||
116 | (let ((size (read-long-long in))) | |
117 | ;; Note: `sendfile' cannot be used here because of port buffering on IN. | |
118 | (dump in out size) | |
119 | ||
120 | (when executable? | |
121 | (chmod out #o755)) | |
122 | (let ((m (modulo size 8))) | |
123 | (unless (zero? m) | |
124 | (get-bytevector-n in (- 8 m)))) | |
125 | size)) | |
126 | ||
127 | (define %archive-version-1 | |
128 | ;; Magic cookie for Nix archives. | |
129 | "nix-archive-1") | |
130 | ||
0f41c26f LC |
131 | (define (write-file file port) |
132 | "Write the contents of FILE to PORT in Nar format, recursing into | |
133 | sub-directories of FILE as needed." | |
0f41c26f LC |
134 | (define p port) |
135 | ||
136 | (write-string %archive-version-1 p) | |
137 | ||
138 | (let dump ((f file)) | |
139 | (let ((s (lstat f))) | |
140 | (write-string "(" p) | |
141 | (case (stat:type s) | |
142 | ((regular) | |
143 | (write-string "type" p) | |
144 | (write-string "regular" p) | |
145 | (if (not (zero? (logand (stat:mode s) #o100))) | |
146 | (begin | |
147 | (write-string "executable" p) | |
148 | (write-string "" p))) | |
149 | (write-contents f p (stat:size s))) | |
150 | ((directory) | |
151 | (write-string "type" p) | |
152 | (write-string "directory" p) | |
153 | (let ((entries (remove (cut member <> '("." "..")) | |
154 | (scandir f)))) | |
155 | (for-each (lambda (e) | |
156 | (let ((f (string-append f "/" e))) | |
157 | (write-string "entry" p) | |
158 | (write-string "(" p) | |
159 | (write-string "name" p) | |
160 | (write-string e p) | |
161 | (write-string "node" p) | |
162 | (dump f) | |
163 | (write-string ")" p))) | |
164 | entries))) | |
8f3114b7 LC |
165 | ((symlink) |
166 | (write-string "type" p) | |
167 | (write-string "symlink" p) | |
168 | (write-string "target" p) | |
169 | (write-string (readlink f) p)) | |
0f41c26f | 170 | (else |
53c63ee9 LC |
171 | (raise (condition (&message (message "ENOSYS")) |
172 | (&nar-error))))) | |
0f41c26f LC |
173 | (write-string ")" p)))) |
174 | ||
53c63ee9 LC |
175 | (define (restore-file port file) |
176 | "Read a file (possibly a directory structure) in Nar format from PORT. | |
177 | Restore it as FILE." | |
178 | (let ((signature (read-string port))) | |
179 | (unless (equal? signature %archive-version-1) | |
180 | (raise | |
181 | (condition (&message (message "invalid nar signature")) | |
182 | (&nar-read-error (port port) | |
183 | (token signature) | |
184 | (file #f)))))) | |
185 | ||
186 | (let restore ((file file)) | |
8f3114b7 LC |
187 | (define (read-eof-marker) |
188 | (match (read-string port) | |
189 | (")" #t) | |
190 | (x (raise | |
191 | (condition | |
192 | (&message (message "invalid nar end-of-file marker")) | |
193 | (&nar-read-error (port port) (file file) (token x))))))) | |
194 | ||
53c63ee9 LC |
195 | (match (list (read-string port) (read-string port) (read-string port)) |
196 | (("(" "type" "regular") | |
197 | (call-with-output-file file (cut read-contents port <>)) | |
8f3114b7 LC |
198 | (read-eof-marker)) |
199 | (("(" "type" "symlink") | |
200 | (match (list (read-string port) (read-string port)) | |
201 | (("target" target) | |
202 | (symlink target file) | |
203 | (read-eof-marker)) | |
53c63ee9 LC |
204 | (x (raise |
205 | (condition | |
8f3114b7 | 206 | (&message (message "invalid symlink tokens")) |
53c63ee9 LC |
207 | (&nar-read-error (port port) (file file) (token x))))))) |
208 | (("(" "type" "directory") | |
209 | (let ((dir file)) | |
210 | (mkdir dir) | |
211 | (let loop ((prefix (read-string port))) | |
212 | (match prefix | |
213 | ("entry" | |
214 | (match (list (read-string port) | |
215 | (read-string port) (read-string port) | |
216 | (read-string port)) | |
217 | (("(" "name" file "node") | |
218 | (restore (string-append dir "/" file)) | |
219 | (match (read-string port) | |
220 | (")" #t) | |
221 | (x | |
222 | (raise | |
223 | (condition | |
224 | (&message | |
225 | (message "unexpected directory entry termination")) | |
226 | (&nar-read-error (port port) | |
227 | (file file) | |
228 | (token x)))))) | |
229 | (loop (read-string port))))) | |
230 | (")" #t) ; done with DIR | |
231 | (x | |
232 | (raise | |
233 | (condition | |
234 | (&message (message "unexpected directory inter-entry marker")) | |
235 | (&nar-read-error (port port) (file file) (token x))))))))) | |
236 | (x | |
237 | (raise | |
238 | (condition | |
239 | (&message (message "unsupported nar entry type")) | |
240 | (&nar-read-error (port port) (file file) (token x)))))))) | |
241 | ||
0f41c26f | 242 | ;;; nar.scm ends here |