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) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (ice-9 rdelim) | |
27 | #:export (nix-server? | |
28 | nix-server-major-version | |
29 | nix-server-minor-version | |
30 | nix-server-socket | |
31 | ||
32 | open-connection | |
33 | set-build-options | |
34 | add-text-to-store | |
35 | add-to-store | |
36 | build-derivations)) | |
37 | ||
38 | (define %protocol-version #x109) | |
39 | ||
40 | (define %worker-magic-1 #x6e697863) | |
41 | (define %worker-magic-2 #x6478696f) | |
42 | ||
43 | (define (protocol-major magic) | |
44 | (logand magic #xff00)) | |
45 | (define (protocol-minor magic) | |
46 | (logand magic #x00ff)) | |
47 | ||
48 | (define-syntax define-enumerate-type | |
49 | (syntax-rules () | |
50 | ((_ name->int (name id) ...) | |
51 | (define-syntax name->int | |
52 | (syntax-rules (name ...) | |
53 | ((_ name) id) ...))))) | |
54 | ||
55 | (define-enumerate-type operation-id | |
56 | ;; operation numbers from worker-protocol.hh | |
57 | (quit 0) | |
58 | (valid-path? 1) | |
59 | (has-substitutes? 3) | |
60 | (query-path-hash 4) | |
61 | (query-references 5) | |
62 | (query-referrers 6) | |
63 | (add-to-store 7) | |
64 | (add-text-to-store 8) | |
65 | (build-derivations 9) | |
66 | (ensure-path 10) | |
67 | (add-temp-root 11) | |
68 | (add-indirect-root 12) | |
69 | (sync-with-gc 13) | |
70 | (find-roots 14) | |
71 | (export-path 16) | |
72 | (query-deriver 18) | |
73 | (set-options 19) | |
74 | (collect-garbage 20) | |
75 | (query-substitutable-path-info 21) | |
76 | (query-derivation-outputs 22) | |
77 | (query-valid-paths 23) | |
78 | (query-failed-paths 24) | |
79 | (clear-failed-paths 25) | |
80 | (query-path-info 26) | |
81 | (import-paths 27) | |
82 | (query-derivation-output-names 28)) | |
83 | ||
84 | (define-enumerate-type hash-algo | |
85 | ;; hash.hh | |
86 | (md5 1) | |
87 | (sha1 2) | |
88 | (sha256 3)) | |
89 | ||
90 | (define %nix-state-dir "/nix/var/nix") | |
91 | (define %default-socket-path | |
92 | (string-append %nix-state-dir "/daemon-socket/socket")) | |
93 | ||
94 | \f | |
95 | ;; serialize.cc | |
96 | ||
97 | (define (write-int n p) | |
98 | (let ((b (make-bytevector 8 0))) | |
99 | (bytevector-u32-set! b 0 n (endianness little)) | |
100 | (put-bytevector p b))) | |
101 | ||
102 | (define (read-int p) | |
103 | (let ((b (get-bytevector-n p 8))) | |
104 | (bytevector-u32-ref b 0 (endianness little)))) | |
105 | ||
106 | (define (write-long-long n p) | |
107 | (let ((b (make-bytevector 8 0))) | |
108 | (bytevector-u64-set! b 0 n (endianness little)) | |
109 | (put-bytevector p b))) | |
110 | ||
111 | (define write-padding | |
112 | (let ((zero (make-bytevector 8 0))) | |
113 | (lambda (n p) | |
114 | (let ((m (modulo n 8))) | |
115 | (or (zero? m) | |
116 | (put-bytevector p zero 0 (- 8 m))))))) | |
117 | ||
118 | (define (write-string s p) | |
119 | (let ((b (string->utf8 s))) | |
120 | (write-int (bytevector-length b) p) | |
121 | (put-bytevector p b) | |
122 | (write-padding (bytevector-length b) p))) | |
123 | ||
124 | (define (read-string p) | |
125 | (let* ((len (read-int p)) | |
126 | (m (modulo len 8)) | |
127 | (bv (get-bytevector-n p len)) | |
128 | (str (utf8->string bv))) | |
129 | (or (zero? m) | |
130 | (get-bytevector-n p (- 8 m))) | |
131 | str)) | |
132 | ||
133 | (define (write-string-list l p) | |
134 | (write-int (length l) p) | |
135 | (for-each (cut write-string <> p) l)) | |
136 | ||
137 | (define (read-store-path p) | |
138 | (read-string p)) ; TODO: assert path | |
139 | ||
140 | (define (write-contents file p) | |
141 | "Write the contents of FILE to output port P." | |
142 | (define (dump in size) | |
143 | (define buf-size 65536) | |
144 | (define buf (make-bytevector buf-size)) | |
145 | ||
146 | (let loop ((left size)) | |
147 | (if (<= left 0) | |
148 | 0 | |
149 | (let ((read (get-bytevector-n! in buf 0 buf-size))) | |
150 | (if (eof-object? read) | |
151 | left | |
152 | (begin | |
153 | (put-bytevector p buf 0 read) | |
154 | (loop (- left read)))))))) | |
155 | ||
156 | (let ((size (stat:size (lstat file)))) | |
157 | (write-string "contents" p) | |
158 | (write-long-long size p) | |
159 | (call-with-input-file file | |
160 | (lambda (p) | |
161 | (dump p size))) | |
162 | (write-padding size p))) | |
163 | ||
164 | (define (write-file f p) | |
165 | (define %archive-version-1 "nix-archive-1") | |
166 | ||
167 | (let ((s (lstat f))) | |
168 | (write-string %archive-version-1 p) | |
169 | (write-string "(" p) | |
170 | (case (stat:type s) | |
171 | ((regular) | |
172 | (write-string "type" p) | |
173 | (write-string "regular" p) | |
174 | (if (not (zero? (logand (stat:mode s) #o100))) | |
175 | (begin | |
176 | (write-string "executable" p) | |
177 | (write-string "" p))) | |
178 | (write-contents f p) | |
179 | (write-string ")" p)) | |
180 | ((directory) | |
181 | (write-string "type" p) | |
182 | (write-string "directory" p) | |
183 | (error "ENOSYS")) | |
184 | (else | |
185 | (error "ENOSYS"))))) | |
186 | ||
187 | (define-syntax write-arg | |
188 | (syntax-rules (integer boolean file string string-list) | |
189 | ((_ integer arg p) | |
190 | (write-int arg p)) | |
191 | ((_ boolean arg p) | |
192 | (write-int (if arg 1 0) p)) | |
193 | ((_ file arg p) | |
194 | (write-file arg p)) | |
195 | ((_ string arg p) | |
196 | (write-string arg p)) | |
197 | ((_ string-list arg p) | |
198 | (write-string-list arg p)))) | |
199 | ||
200 | (define-syntax read-arg | |
201 | (syntax-rules (integer boolean string store-path) | |
202 | ((_ integer p) | |
203 | (read-int p)) | |
204 | ((_ boolean p) | |
205 | (not (zero? (read-int p)))) | |
206 | ((_ string p) | |
207 | (read-string p)) | |
208 | ((_ store-path p) | |
209 | (read-store-path p)))) | |
210 | ||
211 | \f | |
212 | ;; remote-store.cc | |
213 | ||
214 | (define-record-type <nix-server> | |
215 | (%make-nix-server socket major minor) | |
216 | nix-server? | |
217 | (socket nix-server-socket) | |
218 | (major nix-server-major-version) | |
219 | (minor nix-server-minor-version)) | |
220 | ||
221 | (define* (open-connection #:optional (file %default-socket-path)) | |
222 | (let ((s (with-fluids ((%default-port-encoding #f)) | |
223 | ;; This trick allows use of the `scm_c_read' optimization. | |
224 | (socket PF_UNIX SOCK_STREAM 0))) | |
225 | (a (make-socket-address PF_UNIX file))) | |
226 | (connect s a) | |
227 | (write-int %worker-magic-1 s) | |
228 | (let ((r (read-int s))) | |
229 | (and (eqv? r %worker-magic-2) | |
230 | (let ((v (read-int s))) | |
231 | (and (eqv? (protocol-major %protocol-version) | |
232 | (protocol-major v)) | |
233 | (begin | |
234 | (write-int %protocol-version s) | |
235 | (let ((s (%make-nix-server s | |
236 | (protocol-major v) | |
237 | (protocol-minor v)))) | |
238 | (process-stderr s) | |
239 | s)))))))) | |
240 | ||
241 | (define (process-stderr server) | |
242 | (define p | |
243 | (nix-server-socket server)) | |
244 | ||
245 | ;; magic cookies from worker-protocol.hh | |
246 | (define %stderr-next #x6f6c6d67) | |
247 | (define %stderr-read #x64617461) ; data needed from source | |
248 | (define %stderr-write #x64617416) ; data for sink | |
249 | (define %stderr-last #x616c7473) | |
250 | (define %stderr-error #x63787470) | |
251 | ||
252 | (let ((k (read-int p))) | |
253 | (cond ((= k %stderr-write) | |
254 | (read-string p)) | |
255 | ((= k %stderr-read) | |
256 | (let ((len (read-int p))) | |
257 | (read-string p) ; FIXME: what to do? | |
258 | )) | |
259 | ((= k %stderr-next) | |
260 | (let ((s (read-string p))) | |
261 | (display s (current-error-port)) | |
262 | s)) | |
263 | ((= k %stderr-error) | |
264 | (let ((error (read-string p)) | |
265 | (status (if (>= (nix-server-minor-version server) 8) | |
266 | (read-int p) | |
267 | 1))) | |
268 | (format (current-error-port) "error: ~a (status: ~a)~%" | |
269 | error status) | |
270 | error)) | |
271 | ((= k %stderr-last) | |
272 | #t) | |
273 | (else | |
274 | (error "invalid standard error code" k))))) | |
275 | ||
276 | (define* (set-build-options server | |
277 | #:key keep-failed? keep-going? try-fallback? | |
278 | (verbosity 0) | |
279 | (max-build-jobs (current-processor-count)) | |
280 | (max-silent-time 3600) | |
281 | (use-build-hook? #t) | |
282 | (build-verbosity 0) | |
283 | (log-type 0) | |
284 | (print-build-trace #t)) | |
285 | ;; Must be called after `open-connection'. | |
286 | ||
287 | (define socket | |
288 | (nix-server-socket server)) | |
289 | ||
290 | (let-syntax ((send (syntax-rules () | |
291 | ((_ option ...) | |
292 | (for-each (lambda (i) | |
293 | (cond ((boolean? i) | |
294 | (write-int (if i 1 0) socket)) | |
295 | ((integer? i) | |
296 | (write-int i socket)) | |
297 | (else | |
298 | (error "invalid build option" | |
299 | i)))) | |
300 | (list option ...)))))) | |
301 | (send (operation-id set-options) | |
302 | keep-failed? keep-going? try-fallback? verbosity | |
303 | max-build-jobs max-silent-time) | |
304 | (if (>= (nix-server-minor-version server) 2) | |
305 | (send use-build-hook?)) | |
306 | (if (>= (nix-server-minor-version server) 4) | |
307 | (send build-verbosity log-type print-build-trace)) | |
308 | (process-stderr server))) | |
309 | ||
310 | (define-syntax define-operation | |
311 | (syntax-rules () | |
312 | ((_ (name (type arg) ...) docstring return) | |
313 | (define (name server arg ...) | |
314 | docstring | |
315 | (let ((s (nix-server-socket server))) | |
316 | (write-int (operation-id name) s) | |
317 | (write-arg type arg s) | |
318 | ... | |
319 | (process-stderr server) | |
320 | (read-arg return s)))))) | |
321 | ||
322 | (define-operation (add-text-to-store (string name) (string text) | |
323 | (string-list references)) | |
324 | "Add TEXT under file NAME in the store." | |
325 | store-path) | |
326 | ||
327 | (define-operation (add-to-store (string basename) | |
328 | (integer algo) | |
329 | (boolean sha256-and-recursive?) | |
330 | (boolean recursive?) | |
331 | (file file-name)) | |
332 | "Add the contents of FILE-NAME under BASENAME to the store." | |
333 | store-path) | |
334 | ||
335 | (define-operation (build-derivations (string-list derivations)) | |
336 | "Build DERIVATIONS; return #t on success." | |
337 | boolean) |