Commit | Line | Data |
---|---|---|
77d3cf08 LC |
1 | ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- |
2 | ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of Guix. | |
5 | ;;; | |
6 | ;;; 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 | ;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix store) | |
20 | #:use-module (rnrs bytevectors) | |
21 | #:use-module (rnrs io ports) | |
22 | #:use-module (srfi srfi-1) | |
23 | #:use-module (srfi srfi-9) | |
24 | #:use-module (srfi srfi-26) | |
e87088c9 LC |
25 | #:use-module (srfi srfi-34) |
26 | #:use-module (srfi srfi-35) | |
26bbbb95 | 27 | #:use-module (srfi srfi-39) |
77d3cf08 LC |
28 | #:use-module (ice-9 match) |
29 | #:use-module (ice-9 rdelim) | |
b37eb5ed | 30 | #:use-module (ice-9 ftw) |
77d3cf08 LC |
31 | #:export (nix-server? |
32 | nix-server-major-version | |
33 | nix-server-minor-version | |
34 | nix-server-socket | |
35 | ||
e87088c9 LC |
36 | &nix-error nix-error? |
37 | &nix-protocol-error nix-protocol-error? | |
38 | nix-protocol-error-message | |
39 | nix-protocol-error-status | |
40 | ||
26bbbb95 LC |
41 | hash-algo |
42 | ||
77d3cf08 | 43 | open-connection |
3abaf0c4 | 44 | close-connection |
77d3cf08 | 45 | set-build-options |
31ef99a8 | 46 | valid-path? |
77d3cf08 LC |
47 | add-text-to-store |
48 | add-to-store | |
26bbbb95 LC |
49 | build-derivations |
50 | ||
dcee50c1 LC |
51 | current-build-output-port |
52 | ||
26bbbb95 LC |
53 | %store-prefix |
54 | store-path? | |
55 | derivation-path?)) | |
77d3cf08 | 56 | |
e36a7172 | 57 | (define %protocol-version #x10b) |
77d3cf08 LC |
58 | |
59 | (define %worker-magic-1 #x6e697863) | |
60 | (define %worker-magic-2 #x6478696f) | |
61 | ||
62 | (define (protocol-major magic) | |
63 | (logand magic #xff00)) | |
64 | (define (protocol-minor magic) | |
65 | (logand magic #x00ff)) | |
66 | ||
67 | (define-syntax define-enumerate-type | |
68 | (syntax-rules () | |
69 | ((_ name->int (name id) ...) | |
70 | (define-syntax name->int | |
71 | (syntax-rules (name ...) | |
72 | ((_ name) id) ...))))) | |
73 | ||
74 | (define-enumerate-type operation-id | |
75 | ;; operation numbers from worker-protocol.hh | |
76 | (quit 0) | |
77 | (valid-path? 1) | |
78 | (has-substitutes? 3) | |
79 | (query-path-hash 4) | |
80 | (query-references 5) | |
81 | (query-referrers 6) | |
82 | (add-to-store 7) | |
83 | (add-text-to-store 8) | |
84 | (build-derivations 9) | |
85 | (ensure-path 10) | |
86 | (add-temp-root 11) | |
87 | (add-indirect-root 12) | |
88 | (sync-with-gc 13) | |
89 | (find-roots 14) | |
90 | (export-path 16) | |
91 | (query-deriver 18) | |
92 | (set-options 19) | |
93 | (collect-garbage 20) | |
94 | (query-substitutable-path-info 21) | |
95 | (query-derivation-outputs 22) | |
96 | (query-valid-paths 23) | |
97 | (query-failed-paths 24) | |
98 | (clear-failed-paths 25) | |
99 | (query-path-info 26) | |
100 | (import-paths 27) | |
101 | (query-derivation-output-names 28)) | |
102 | ||
103 | (define-enumerate-type hash-algo | |
104 | ;; hash.hh | |
105 | (md5 1) | |
106 | (sha1 2) | |
107 | (sha256 3)) | |
108 | ||
109 | (define %nix-state-dir "/nix/var/nix") | |
110 | (define %default-socket-path | |
111 | (string-append %nix-state-dir "/daemon-socket/socket")) | |
112 | ||
113 | \f | |
114 | ;; serialize.cc | |
115 | ||
116 | (define (write-int n p) | |
117 | (let ((b (make-bytevector 8 0))) | |
118 | (bytevector-u32-set! b 0 n (endianness little)) | |
119 | (put-bytevector p b))) | |
120 | ||
121 | (define (read-int p) | |
122 | (let ((b (get-bytevector-n p 8))) | |
123 | (bytevector-u32-ref b 0 (endianness little)))) | |
124 | ||
125 | (define (write-long-long n p) | |
126 | (let ((b (make-bytevector 8 0))) | |
127 | (bytevector-u64-set! b 0 n (endianness little)) | |
128 | (put-bytevector p b))) | |
129 | ||
130 | (define write-padding | |
131 | (let ((zero (make-bytevector 8 0))) | |
132 | (lambda (n p) | |
133 | (let ((m (modulo n 8))) | |
134 | (or (zero? m) | |
135 | (put-bytevector p zero 0 (- 8 m))))))) | |
136 | ||
137 | (define (write-string s p) | |
138 | (let ((b (string->utf8 s))) | |
139 | (write-int (bytevector-length b) p) | |
140 | (put-bytevector p b) | |
141 | (write-padding (bytevector-length b) p))) | |
142 | ||
143 | (define (read-string p) | |
144 | (let* ((len (read-int p)) | |
145 | (m (modulo len 8)) | |
146 | (bv (get-bytevector-n p len)) | |
147 | (str (utf8->string bv))) | |
148 | (or (zero? m) | |
149 | (get-bytevector-n p (- 8 m))) | |
150 | str)) | |
151 | ||
152 | (define (write-string-list l p) | |
153 | (write-int (length l) p) | |
154 | (for-each (cut write-string <> p) l)) | |
155 | ||
156 | (define (read-store-path p) | |
157 | (read-string p)) ; TODO: assert path | |
158 | ||
159 | (define (write-contents file p) | |
160 | "Write the contents of FILE to output port P." | |
161 | (define (dump in size) | |
162 | (define buf-size 65536) | |
163 | (define buf (make-bytevector buf-size)) | |
164 | ||
165 | (let loop ((left size)) | |
166 | (if (<= left 0) | |
167 | 0 | |
168 | (let ((read (get-bytevector-n! in buf 0 buf-size))) | |
169 | (if (eof-object? read) | |
170 | left | |
171 | (begin | |
172 | (put-bytevector p buf 0 read) | |
173 | (loop (- left read)))))))) | |
174 | ||
175 | (let ((size (stat:size (lstat file)))) | |
176 | (write-string "contents" p) | |
177 | (write-long-long size p) | |
178 | (call-with-input-file file | |
179 | (lambda (p) | |
180 | (dump p size))) | |
181 | (write-padding size p))) | |
182 | ||
183 | (define (write-file f p) | |
184 | (define %archive-version-1 "nix-archive-1") | |
185 | ||
b37eb5ed LC |
186 | (write-string %archive-version-1 p) |
187 | ||
188 | (let dump ((f f)) | |
189 | (let ((s (lstat f))) | |
190 | (write-string "(" p) | |
191 | (case (stat:type s) | |
192 | ((regular) | |
193 | (write-string "type" p) | |
194 | (write-string "regular" p) | |
195 | (if (not (zero? (logand (stat:mode s) #o100))) | |
196 | (begin | |
197 | (write-string "executable" p) | |
198 | (write-string "" p))) | |
199 | (write-contents f p)) | |
200 | ((directory) | |
201 | (write-string "type" p) | |
202 | (write-string "directory" p) | |
203 | (let ((entries (remove (cut member <> '("." "..")) | |
204 | (scandir f)))) | |
205 | (for-each (lambda (e) | |
206 | (let ((f (string-append f "/" e))) | |
207 | (write-string "entry" p) | |
208 | (write-string "(" p) | |
209 | (write-string "name" p) | |
210 | (write-string e p) | |
211 | (write-string "node" p) | |
212 | (dump f) | |
213 | (write-string ")" p))) | |
214 | entries))) | |
215 | (else | |
216 | (error "ENOSYS"))) | |
217 | (write-string ")" p)))) | |
77d3cf08 LC |
218 | |
219 | (define-syntax write-arg | |
220 | (syntax-rules (integer boolean file string string-list) | |
221 | ((_ integer arg p) | |
222 | (write-int arg p)) | |
223 | ((_ boolean arg p) | |
224 | (write-int (if arg 1 0) p)) | |
225 | ((_ file arg p) | |
226 | (write-file arg p)) | |
227 | ((_ string arg p) | |
228 | (write-string arg p)) | |
229 | ((_ string-list arg p) | |
230 | (write-string-list arg p)))) | |
231 | ||
232 | (define-syntax read-arg | |
233 | (syntax-rules (integer boolean string store-path) | |
234 | ((_ integer p) | |
235 | (read-int p)) | |
236 | ((_ boolean p) | |
237 | (not (zero? (read-int p)))) | |
238 | ((_ string p) | |
239 | (read-string p)) | |
240 | ((_ store-path p) | |
241 | (read-store-path p)))) | |
242 | ||
243 | \f | |
244 | ;; remote-store.cc | |
245 | ||
246 | (define-record-type <nix-server> | |
247 | (%make-nix-server socket major minor) | |
248 | nix-server? | |
249 | (socket nix-server-socket) | |
250 | (major nix-server-major-version) | |
251 | (minor nix-server-minor-version)) | |
252 | ||
e87088c9 LC |
253 | (define-condition-type &nix-error &error |
254 | nix-error?) | |
255 | ||
256 | (define-condition-type &nix-protocol-error &nix-error | |
257 | nix-protocol-error? | |
258 | (message nix-protocol-error-message) | |
259 | (status nix-protocol-error-status)) | |
260 | ||
e36a7172 LC |
261 | (define* (open-connection #:optional (file %default-socket-path) |
262 | #:key (reserve-space? #t)) | |
77d3cf08 LC |
263 | (let ((s (with-fluids ((%default-port-encoding #f)) |
264 | ;; This trick allows use of the `scm_c_read' optimization. | |
265 | (socket PF_UNIX SOCK_STREAM 0))) | |
266 | (a (make-socket-address PF_UNIX file))) | |
267 | (connect s a) | |
268 | (write-int %worker-magic-1 s) | |
269 | (let ((r (read-int s))) | |
270 | (and (eqv? r %worker-magic-2) | |
271 | (let ((v (read-int s))) | |
272 | (and (eqv? (protocol-major %protocol-version) | |
273 | (protocol-major v)) | |
274 | (begin | |
275 | (write-int %protocol-version s) | |
e36a7172 LC |
276 | (if (>= (protocol-minor v) 11) |
277 | (write-int (if reserve-space? 1 0) s)) | |
77d3cf08 LC |
278 | (let ((s (%make-nix-server s |
279 | (protocol-major v) | |
280 | (protocol-minor v)))) | |
281 | (process-stderr s) | |
282 | s)))))))) | |
283 | ||
3abaf0c4 LC |
284 | (define (close-connection server) |
285 | "Close the connection to SERVER." | |
286 | (close (nix-server-socket server))) | |
287 | ||
dcee50c1 LC |
288 | (define current-build-output-port |
289 | ;; The port where build output is sent. | |
290 | (make-parameter (current-error-port))) | |
291 | ||
77d3cf08 | 292 | (define (process-stderr server) |
dcee50c1 LC |
293 | "Read standard output and standard error from SERVER, writing it to |
294 | CURRENT-BUILD-OUTPUT-PORT. Return #t when SERVER is done sending data, and | |
295 | #f otherwise; in the latter case, the caller should call `process-stderr' | |
296 | again until #t is returned or an error is raised." | |
77d3cf08 LC |
297 | (define p |
298 | (nix-server-socket server)) | |
299 | ||
300 | ;; magic cookies from worker-protocol.hh | |
301 | (define %stderr-next #x6f6c6d67) | |
302 | (define %stderr-read #x64617461) ; data needed from source | |
303 | (define %stderr-write #x64617416) ; data for sink | |
304 | (define %stderr-last #x616c7473) | |
305 | (define %stderr-error #x63787470) | |
306 | ||
307 | (let ((k (read-int p))) | |
308 | (cond ((= k %stderr-write) | |
dcee50c1 LC |
309 | (read-string p) |
310 | #f) | |
77d3cf08 LC |
311 | ((= k %stderr-read) |
312 | (let ((len (read-int p))) | |
313 | (read-string p) ; FIXME: what to do? | |
dcee50c1 | 314 | #f)) |
77d3cf08 LC |
315 | ((= k %stderr-next) |
316 | (let ((s (read-string p))) | |
dcee50c1 LC |
317 | (display s (current-build-output-port)) |
318 | #f)) | |
77d3cf08 LC |
319 | ((= k %stderr-error) |
320 | (let ((error (read-string p)) | |
321 | (status (if (>= (nix-server-minor-version server) 8) | |
322 | (read-int p) | |
323 | 1))) | |
e87088c9 LC |
324 | (raise (condition (&nix-protocol-error |
325 | (message error) | |
326 | (status status)))))) | |
77d3cf08 | 327 | ((= k %stderr-last) |
dcee50c1 | 328 | ;; The daemon is done (see `stopWork' in `nix-worker.cc'.) |
77d3cf08 LC |
329 | #t) |
330 | (else | |
e87088c9 LC |
331 | (raise (condition (&nix-protocol-error |
332 | (message "invalid error code") | |
333 | (status k)))))))) | |
77d3cf08 LC |
334 | |
335 | (define* (set-build-options server | |
336 | #:key keep-failed? keep-going? try-fallback? | |
337 | (verbosity 0) | |
338 | (max-build-jobs (current-processor-count)) | |
339 | (max-silent-time 3600) | |
340 | (use-build-hook? #t) | |
341 | (build-verbosity 0) | |
342 | (log-type 0) | |
e036c31b LC |
343 | (print-build-trace #t) |
344 | (build-cores 1) | |
345 | (use-substitutes? #t)) | |
77d3cf08 LC |
346 | ;; Must be called after `open-connection'. |
347 | ||
348 | (define socket | |
349 | (nix-server-socket server)) | |
350 | ||
351 | (let-syntax ((send (syntax-rules () | |
e036c31b LC |
352 | ((_ (type option) ...) |
353 | (begin | |
354 | (write-arg type option socket) | |
355 | ...))))) | |
356 | (write-int (operation-id set-options) socket) | |
357 | (send (boolean keep-failed?) (boolean keep-going?) | |
358 | (boolean try-fallback?) (integer verbosity) | |
359 | (integer max-build-jobs) (integer max-silent-time)) | |
77d3cf08 | 360 | (if (>= (nix-server-minor-version server) 2) |
e036c31b | 361 | (send (boolean use-build-hook?))) |
77d3cf08 | 362 | (if (>= (nix-server-minor-version server) 4) |
e036c31b LC |
363 | (send (integer build-verbosity) (integer log-type) |
364 | (boolean print-build-trace))) | |
365 | (if (>= (nix-server-minor-version server) 6) | |
366 | (send (integer build-cores))) | |
367 | (if (>= (nix-server-minor-version server) 10) | |
368 | (send (boolean use-substitutes?))) | |
dcee50c1 LC |
369 | (let loop ((done? (process-stderr server))) |
370 | (or done? (process-stderr server))))) | |
77d3cf08 LC |
371 | |
372 | (define-syntax define-operation | |
373 | (syntax-rules () | |
374 | ((_ (name (type arg) ...) docstring return) | |
375 | (define (name server arg ...) | |
376 | docstring | |
377 | (let ((s (nix-server-socket server))) | |
378 | (write-int (operation-id name) s) | |
379 | (write-arg type arg s) | |
380 | ... | |
dcee50c1 LC |
381 | ;; Loop until the server is done sending error output. |
382 | (let loop ((done? (process-stderr server))) | |
383 | (or done? (loop (process-stderr server)))) | |
77d3cf08 LC |
384 | (read-arg return s)))))) |
385 | ||
31ef99a8 LC |
386 | (define-operation (valid-path? (string path)) |
387 | "Return #t when PATH is a valid store path." | |
388 | boolean) | |
389 | ||
77d3cf08 LC |
390 | (define-operation (add-text-to-store (string name) (string text) |
391 | (string-list references)) | |
392 | "Add TEXT under file NAME in the store." | |
393 | store-path) | |
394 | ||
395 | (define-operation (add-to-store (string basename) | |
b37eb5ed | 396 | (boolean fixed?) ; obsolete, must be #t |
77d3cf08 | 397 | (boolean recursive?) |
b37eb5ed | 398 | (string hash-algo) |
77d3cf08 LC |
399 | (file file-name)) |
400 | "Add the contents of FILE-NAME under BASENAME to the store." | |
401 | store-path) | |
402 | ||
403 | (define-operation (build-derivations (string-list derivations)) | |
dcee50c1 LC |
404 | "Build DERIVATIONS, and return when the worker is done building them. |
405 | Return #t on success." | |
77d3cf08 | 406 | boolean) |
26bbbb95 LC |
407 | |
408 | \f | |
409 | ;;; | |
410 | ;;; Store paths. | |
411 | ;;; | |
412 | ||
413 | (define %store-prefix | |
414 | ;; Absolute path to the Nix store. | |
415 | (make-parameter "/nix/store")) | |
416 | ||
f39bd08a LC |
417 | (define (store-path? path) |
418 | "Return #t if PATH is a store path." | |
419 | ;; This is a lightweight check, compared to using a regexp, but this has to | |
420 | ;; be fast as it's called often in `derivation', for instance. | |
421 | ;; `isStorePath' in Nix does something similar. | |
422 | (string-prefix? (%store-prefix) path)) | |
26bbbb95 LC |
423 | |
424 | (define (derivation-path? path) | |
425 | "Return #t if PATH is a derivation path." | |
426 | (and (store-path? path) (string-suffix? ".drv" path))) |