Commit | Line | Data |
---|---|---|
aff8ce7c DT |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> | |
66229b04 | 3 | ;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
aff8ce7c DT |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix scripts publish) | |
21 | #:use-module ((system repl server) #:prefix repl:) | |
22 | #:use-module (ice-9 binary-ports) | |
23 | #:use-module (ice-9 format) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 regex) | |
2535635f | 26 | #:use-module (ice-9 rdelim) |
00753f70 | 27 | #:use-module (ice-9 threads) |
aff8ce7c DT |
28 | #:use-module (rnrs bytevectors) |
29 | #:use-module (srfi srfi-1) | |
30 | #:use-module (srfi srfi-2) | |
4a1fc562 | 31 | #:use-module (srfi srfi-9) |
94080a72 | 32 | #:use-module (srfi srfi-9 gnu) |
e4c7a5f7 | 33 | #:use-module (srfi srfi-19) |
aff8ce7c | 34 | #:use-module (srfi srfi-26) |
ff6638d1 | 35 | #:use-module (srfi srfi-34) |
aff8ce7c DT |
36 | #:use-module (srfi srfi-37) |
37 | #:use-module (web http) | |
38 | #:use-module (web request) | |
39 | #:use-module (web response) | |
40 | #:use-module (web server) | |
41 | #:use-module (web uri) | |
e1bbc0e3 | 42 | #:autoload (sxml simple) (sxml->xml) |
aff8ce7c DT |
43 | #:use-module (guix base32) |
44 | #:use-module (guix base64) | |
45 | #:use-module (guix config) | |
46 | #:use-module (guix derivations) | |
ca719424 | 47 | #:use-module (gcrypt hash) |
aff8ce7c | 48 | #:use-module (guix pki) |
ca719424 | 49 | #:use-module (gcrypt pk-crypto) |
00753f70 | 50 | #:use-module (guix workers) |
aff8ce7c | 51 | #:use-module (guix store) |
2535635f | 52 | #:use-module ((guix serialization) #:select (write-file)) |
4a1fc562 | 53 | #:use-module (guix zlib) |
66229b04 | 54 | #:autoload (guix lzlib) (lzlib-available?) |
d72b4206 | 55 | #:use-module (guix cache) |
aff8ce7c | 56 | #:use-module (guix ui) |
88981dd3 | 57 | #:use-module (guix scripts) |
00753f70 LC |
58 | #:use-module ((guix utils) |
59 | #:select (with-atomic-file-output compressed-file?)) | |
d72b4206 LC |
60 | #:use-module ((guix build utils) |
61 | #:select (dump-port mkdir-p find-files)) | |
8902d0f2 | 62 | #:use-module ((guix build syscalls) #:select (set-thread-name)) |
ab2a74e4 LC |
63 | #:export (%public-key |
64 | %private-key | |
65 | ||
66 | guix-publish)) | |
aff8ce7c DT |
67 | |
68 | (define (show-help) | |
69daee23 | 69 | (format #t (G_ "Usage: guix publish [OPTION]... |
aff8ce7c | 70 | Publish ~a over HTTP.\n") %store-directory) |
69daee23 | 71 | (display (G_ " |
aff8ce7c | 72 | -p, --port=PORT listen on PORT")) |
69daee23 | 73 | (display (G_ " |
9e2292ef | 74 | --listen=HOST listen on the network interface for HOST")) |
69daee23 | 75 | (display (G_ " |
5463fe51 | 76 | -u, --user=USER change privileges to USER as soon as possible")) |
69daee23 | 77 | (display (G_ " |
66229b04 LC |
78 | -C, --compression[=METHOD:LEVEL] |
79 | compress archives with METHOD at LEVEL")) | |
69daee23 | 80 | (display (G_ " |
00753f70 | 81 | -c, --cache=DIRECTORY cache published items to DIRECTORY")) |
69daee23 | 82 | (display (G_ " |
00753f70 | 83 | --workers=N use N workers to bake items")) |
69daee23 | 84 | (display (G_ " |
e4c7a5f7 | 85 | --ttl=TTL announce narinfos can be cached for TTL seconds")) |
69daee23 | 86 | (display (G_ " |
4bb5e0ae | 87 | --nar-path=PATH use PATH as the prefix for nar URLs")) |
69daee23 | 88 | (display (G_ " |
46f58390 | 89 | --public-key=FILE use FILE as the public key for signatures")) |
69daee23 | 90 | (display (G_ " |
46f58390 | 91 | --private-key=FILE use FILE as the private key for signatures")) |
69daee23 | 92 | (display (G_ " |
aff8ce7c DT |
93 | -r, --repl[=PORT] spawn REPL server on PORT")) |
94 | (newline) | |
69daee23 | 95 | (display (G_ " |
aff8ce7c | 96 | -h, --help display this help and exit")) |
69daee23 | 97 | (display (G_ " |
aff8ce7c DT |
98 | -V, --version display version information and exit")) |
99 | (newline) | |
100 | (show-bug-report-information)) | |
101 | ||
9e2292ef LC |
102 | (define (getaddrinfo* host) |
103 | "Like 'getaddrinfo', but properly report errors." | |
104 | (catch 'getaddrinfo-error | |
105 | (lambda () | |
106 | (getaddrinfo host)) | |
107 | (lambda (key error) | |
69daee23 | 108 | (leave (G_ "lookup of host '~a' failed: ~a~%") |
9e2292ef LC |
109 | host (gai-strerror error))))) |
110 | ||
4a1fc562 LC |
111 | ;; Nar compression parameters. |
112 | (define-record-type <compression> | |
113 | (compression type level) | |
114 | compression? | |
115 | (type compression-type) | |
116 | (level compression-level)) | |
117 | ||
118 | (define %no-compression | |
119 | (compression 'none 0)) | |
120 | ||
121 | (define %default-gzip-compression | |
122 | ;; Since we compress on the fly, default to fast compression. | |
123 | (compression 'gzip 3)) | |
124 | ||
66229b04 LC |
125 | (define (default-compression type) |
126 | (compression type 3)) | |
127 | ||
b8fa86ad LC |
128 | (define (actual-compressions item requested) |
129 | "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION | |
905ae527 LC |
130 | if ITEM is already compressed." |
131 | (if (compressed-file? item) | |
b8fa86ad | 132 | (list %no-compression) |
905ae527 LC |
133 | requested)) |
134 | ||
aff8ce7c DT |
135 | (define %options |
136 | (list (option '(#\h "help") #f #f | |
137 | (lambda _ | |
138 | (show-help) | |
139 | (exit 0))) | |
140 | (option '(#\V "version") #f #f | |
141 | (lambda _ | |
142 | (show-version-and-exit "guix publish"))) | |
5463fe51 LC |
143 | (option '(#\u "user") #t #f |
144 | (lambda (opt name arg result) | |
145 | (alist-cons 'user arg result))) | |
aff8ce7c DT |
146 | (option '(#\p "port") #t #f |
147 | (lambda (opt name arg result) | |
148 | (alist-cons 'port (string->number* arg) result))) | |
9e2292ef LC |
149 | (option '("listen") #t #f |
150 | (lambda (opt name arg result) | |
151 | (match (getaddrinfo* arg) | |
152 | ((info _ ...) | |
153 | (alist-cons 'address (addrinfo:addr info) | |
154 | result)) | |
155 | (() | |
69daee23 | 156 | (leave (G_ "lookup of host '~a' returned nothing") |
9e2292ef | 157 | name))))) |
4a1fc562 LC |
158 | (option '(#\C "compression") #f #t |
159 | (lambda (opt name arg result) | |
66229b04 LC |
160 | (let* ((colon (string-index arg #\:)) |
161 | (type (cond | |
162 | (colon (string-take arg colon)) | |
163 | ((string->number arg) "gzip") | |
164 | (else arg))) | |
165 | (level (if colon | |
166 | (string->number* | |
167 | (string-drop arg (+ 1 colon))) | |
168 | (or (string->number arg) 3)))) | |
169 | (match level | |
170 | (0 | |
171 | (alist-cons 'compression %no-compression result)) | |
172 | (level | |
173 | (match (string->compression-type type) | |
174 | ((? symbol? type) | |
175 | (alist-cons 'compression | |
176 | (compression type level) | |
177 | result)) | |
178 | (_ | |
179 | (warning (G_ "~a: unsupported compression type~%") | |
180 | type) | |
181 | result))))))) | |
00753f70 LC |
182 | (option '(#\c "cache") #t #f |
183 | (lambda (opt name arg result) | |
184 | (alist-cons 'cache arg result))) | |
185 | (option '("workers") #t #f | |
186 | (lambda (opt name arg result) | |
187 | (alist-cons 'workers (string->number* arg) | |
188 | result))) | |
e4c7a5f7 LC |
189 | (option '("ttl") #t #f |
190 | (lambda (opt name arg result) | |
191 | (let ((duration (string->duration arg))) | |
192 | (unless duration | |
69daee23 | 193 | (leave (G_ "~a: invalid duration~%") arg)) |
e4c7a5f7 LC |
194 | (alist-cons 'narinfo-ttl (time-second duration) |
195 | result)))) | |
4bb5e0ae LC |
196 | (option '("nar-path") #t #f |
197 | (lambda (opt name arg result) | |
198 | (alist-cons 'nar-path arg result))) | |
46f58390 LC |
199 | (option '("public-key") #t #f |
200 | (lambda (opt name arg result) | |
201 | (alist-cons 'public-key-file arg result))) | |
202 | (option '("private-key" "secret-key") #t #f | |
203 | (lambda (opt name arg result) | |
204 | (alist-cons 'private-key-file arg result))) | |
aff8ce7c DT |
205 | (option '(#\r "repl") #f #t |
206 | (lambda (opt name arg result) | |
207 | ;; If port unspecified, use default Guile REPL port. | |
208 | (let ((port (and arg (string->number* arg)))) | |
209 | (alist-cons 'repl (or port 37146) result)))))) | |
210 | ||
211 | (define %default-options | |
9e2292ef | 212 | `((port . 8080) |
4a1fc562 | 213 | |
4bb5e0ae LC |
214 | ;; By default, serve nars under "/nar". |
215 | (nar-path . "nar") | |
216 | ||
ab2a74e4 LC |
217 | (public-key-file . ,%public-key-file) |
218 | (private-key-file . ,%private-key-file) | |
219 | ||
00753f70 LC |
220 | ;; Default number of workers when caching is enabled. |
221 | (workers . ,(current-processor-count)) | |
222 | ||
9e2292ef | 223 | (address . ,(make-socket-address AF_INET INADDR_ANY 0)) |
aff8ce7c DT |
224 | (repl . #f))) |
225 | ||
ab2a74e4 | 226 | ;; The key pair used to sign narinfos. |
aff8ce7c | 227 | (define %private-key |
ab2a74e4 | 228 | (make-parameter #f)) |
aff8ce7c | 229 | (define %public-key |
ab2a74e4 | 230 | (make-parameter #f)) |
aff8ce7c DT |
231 | |
232 | (define %nix-cache-info | |
233 | `(("StoreDir" . ,%store-directory) | |
234 | ("WantMassQuery" . 0) | |
235 | ("Priority" . 100))) | |
236 | ||
aff8ce7c DT |
237 | (define (signed-string s) |
238 | "Sign the hash of the string S with the daemon's key." | |
ab2a74e4 | 239 | (let* ((public-key (%public-key)) |
aff8ce7c DT |
240 | (hash (bytevector->hash-data (sha256 (string->utf8 s)) |
241 | #:key-type (key-type public-key)))) | |
ab2a74e4 | 242 | (signature-sexp hash (%private-key) public-key))) |
aff8ce7c DT |
243 | |
244 | (define base64-encode-string | |
245 | (compose base64-encode string->utf8)) | |
246 | ||
b8fa86ad LC |
247 | (define* (store-item->recutils store-item |
248 | #:key | |
249 | (nar-path "nar") | |
250 | (compression %no-compression) | |
251 | file-size) | |
252 | "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM, | |
253 | with COMPRESSION, starting at NAR-PATH." | |
254 | (let ((url (encode-and-join-uri-path | |
255 | `(,@(split-and-decode-uri-path nar-path) | |
256 | ,@(match compression | |
257 | (($ <compression> 'none) | |
258 | '()) | |
259 | (($ <compression> type) | |
260 | (list (symbol->string type)))) | |
261 | ,(basename store-item))))) | |
262 | (format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]" | |
263 | url (compression-type compression) file-size))) | |
264 | ||
4a1fc562 | 265 | (define* (narinfo-string store store-path key |
b8fa86ad LC |
266 | #:key (compressions (list %no-compression)) |
267 | (nar-path "nar") (file-sizes '())) | |
4d459d87 | 268 | "Generate a narinfo key/value string for STORE-PATH; an exception is raised |
4a1fc562 | 269 | if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The |
dff3189c | 270 | narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs. |
b8fa86ad LC |
271 | |
272 | Optionally, FILE-SIZES is a list of compression/integer pairs, where the | |
273 | integer is size in bytes of the compressed NAR; it informs the client of how | |
274 | much needs to be downloaded." | |
4d459d87 | 275 | (let* ((path-info (query-path-info store store-path)) |
b8fa86ad | 276 | (compressions (actual-compressions store-path compressions)) |
3b307162 | 277 | (hash (bytevector->nix-base32-string |
aff8ce7c DT |
278 | (path-info-hash path-info))) |
279 | (size (path-info-nar-size path-info)) | |
b8fa86ad | 280 | (file-sizes `((,%no-compression . ,size) ,@file-sizes)) |
aff8ce7c DT |
281 | (references (string-join |
282 | (map basename (path-info-references path-info)) | |
283 | " ")) | |
9d2f48df | 284 | (deriver (path-info-deriver path-info)) |
aff8ce7c | 285 | (base-info (format #f |
4a1fc562 LC |
286 | "\ |
287 | StorePath: ~a | |
b8fa86ad | 288 | ~{~a~}\ |
aff8ce7c DT |
289 | NarHash: sha256:~a |
290 | NarSize: ~d | |
b8fa86ad LC |
291 | References: ~a~%" |
292 | store-path | |
293 | (map (lambda (compression) | |
294 | (let ((size (assoc-ref file-sizes | |
295 | compression))) | |
296 | (store-item->recutils store-path | |
297 | #:file-size size | |
298 | #:nar-path nar-path | |
299 | #:compression | |
300 | compression))) | |
301 | compressions) | |
302 | hash size references)) | |
aff8ce7c DT |
303 | ;; Do not render a "Deriver" or "System" line if we are rendering |
304 | ;; info for a derivation. | |
22572d56 | 305 | (info (if (not deriver) |
9d2f48df LC |
306 | base-info |
307 | (catch 'system-error | |
308 | (lambda () | |
015f17e8 | 309 | (let ((drv (read-derivation-from-file deriver))) |
9d2f48df LC |
310 | (format #f "~aSystem: ~a~%Deriver: ~a~%" |
311 | base-info (derivation-system drv) | |
312 | (basename deriver)))) | |
313 | (lambda args | |
314 | ;; DERIVER might be missing, but that's fine: | |
315 | ;; it's only used for <substitutable> where it's | |
316 | ;; optional. 'System' is currently unused. | |
317 | (if (= ENOENT (system-error-errno args)) | |
318 | base-info | |
319 | (apply throw args)))))) | |
aff8ce7c DT |
320 | (signature (base64-encode-string |
321 | (canonical-sexp->string (signed-string info))))) | |
322 | (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) | |
323 | ||
24b21720 LC |
324 | (define* (not-found request |
325 | #:key (phrase "Resource not found") | |
326 | ttl) | |
aff8ce7c | 327 | "Render 404 response for REQUEST." |
24b21720 LC |
328 | (values (build-response #:code 404 |
329 | #:headers (if ttl | |
330 | `((cache-control (max-age . ,ttl))) | |
331 | '())) | |
332 | (string-append phrase ": " | |
aff8ce7c DT |
333 | (uri-path (request-uri request))))) |
334 | ||
335 | (define (render-nix-cache-info) | |
336 | "Render server information." | |
337 | (values '((content-type . (text/plain))) | |
338 | (lambda (port) | |
339 | (for-each (match-lambda | |
340 | ((key . value) | |
341 | (format port "~a: ~a~%" key value))) | |
342 | %nix-cache-info)))) | |
343 | ||
4a1fc562 | 344 | (define* (render-narinfo store request hash |
b8fa86ad | 345 | #:key ttl (compressions (list %no-compression)) |
cdd7a7d2 | 346 | (nar-path "nar")) |
e4c7a5f7 LC |
347 | "Render metadata for the store path corresponding to HASH. If TTL is true, |
348 | advertise it as the maximum validity period (in seconds) via the | |
349 | 'Cache-Control' header. This allows 'guix substitute' to cache it for an | |
cdd7a7d2 | 350 | appropriate duration. NAR-PATH specifies the prefix for nar URLs." |
4d459d87 LC |
351 | (let ((store-path (hash-part->path store hash))) |
352 | (if (string-null? store-path) | |
f3966117 | 353 | (not-found request #:phrase "") |
e4c7a5f7 LC |
354 | (values `((content-type . (application/x-nix-narinfo)) |
355 | ,@(if ttl | |
356 | `((cache-control (max-age . ,ttl))) | |
357 | '())) | |
aff8ce7c | 358 | (cut display |
ab2a74e4 | 359 | (narinfo-string store store-path (%private-key) |
cdd7a7d2 | 360 | #:nar-path nar-path |
b8fa86ad | 361 | #:compressions compressions) |
4a1fc562 LC |
362 | <>))))) |
363 | ||
00753f70 LC |
364 | (define* (nar-cache-file directory item |
365 | #:key (compression %no-compression)) | |
366 | (string-append directory "/" | |
367 | (symbol->string (compression-type compression)) | |
368 | "/" (basename item) ".nar")) | |
369 | ||
370 | (define* (narinfo-cache-file directory item | |
371 | #:key (compression %no-compression)) | |
372 | (string-append directory "/" | |
373 | (symbol->string (compression-type compression)) | |
374 | "/" (basename item) | |
375 | ".narinfo")) | |
376 | ||
493375cd LC |
377 | (define (hash-part-mapping-cache-file directory hash) |
378 | (string-append directory "/hashes/" hash)) | |
379 | ||
00753f70 LC |
380 | (define run-single-baker |
381 | (let ((baking (make-weak-value-hash-table)) | |
382 | (mutex (make-mutex))) | |
383 | (lambda (item thunk) | |
384 | "Run THUNK, which is supposed to bake ITEM, but make sure only one | |
385 | thread is baking ITEM at a given time." | |
386 | (define selected? | |
387 | (with-mutex mutex | |
388 | (and (not (hash-ref baking item)) | |
389 | (begin | |
390 | (hash-set! baking item (current-thread)) | |
391 | #t)))) | |
392 | ||
393 | (when selected? | |
394 | (dynamic-wind | |
395 | (const #t) | |
396 | thunk | |
397 | (lambda () | |
398 | (with-mutex mutex | |
399 | (hash-remove! baking item)))))))) | |
400 | ||
401 | (define-syntax-rule (single-baker item exp ...) | |
402 | "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM | |
403 | at a time." | |
404 | (run-single-baker item (lambda () exp ...))) | |
405 | ||
406 | ||
d72b4206 LC |
407 | (define (narinfo-files cache) |
408 | "Return the list of .narinfo files under CACHE." | |
409 | (if (file-is-directory? cache) | |
410 | (find-files cache | |
411 | (lambda (file stat) | |
412 | (string-suffix? ".narinfo" file))) | |
413 | '())) | |
414 | ||
c95644f0 LC |
415 | (define (nar-expiration-time ttl) |
416 | "Return the narinfo expiration time (in seconds since the Epoch). The | |
417 | expiration time is +inf.0 when passed an item that is still in the store; in | |
418 | other cases, it is the last-access time of the item plus TTL. | |
419 | ||
420 | This policy allows us to keep cached nars that correspond to valid store | |
421 | items. Failing that, we could eventually have to recompute them and return | |
422 | 404 in the meantime." | |
423 | (let ((expiration-time (file-expiration-time ttl))) | |
424 | (lambda (file) | |
425 | (let ((item (string-append (%store-prefix) "/" | |
426 | (basename file ".narinfo")))) | |
427 | ;; Note: We don't need to use 'valid-path?' here because FILE would | |
428 | ;; not exist if ITEM were not valid in the first place. | |
429 | (if (file-exists? item) | |
430 | +inf.0 | |
431 | (expiration-time file)))))) | |
432 | ||
493375cd LC |
433 | (define (hash-part->path* store hash cache) |
434 | "Like 'hash-part->path' but cached results under CACHE. This ensures we can | |
435 | still map HASH to the corresponding store file name, even if said store item | |
436 | vanished from the store in the meantime." | |
437 | (let ((cached (hash-part-mapping-cache-file cache hash))) | |
438 | (catch 'system-error | |
439 | (lambda () | |
440 | (call-with-input-file cached read-string)) | |
441 | (lambda args | |
442 | (if (= ENOENT (system-error-errno args)) | |
443 | (match (hash-part->path store hash) | |
444 | ("" "") | |
445 | (result | |
446 | (mkdir-p (dirname cached)) | |
447 | (call-with-output-file (string-append cached ".tmp") | |
448 | (lambda (port) | |
449 | (display result port))) | |
450 | (rename-file (string-append cached ".tmp") cached) | |
451 | result)) | |
452 | (apply throw args)))))) | |
453 | ||
00753f70 | 454 | (define* (render-narinfo/cached store request hash |
b8fa86ad | 455 | #:key ttl (compressions (list %no-compression)) |
00753f70 LC |
456 | (nar-path "nar") |
457 | cache pool) | |
458 | "Respond to the narinfo request for REQUEST. If the narinfo is available in | |
459 | CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo | |
460 | requested using POOL." | |
d72b4206 LC |
461 | (define (delete-entry narinfo) |
462 | ;; Delete NARINFO and the corresponding nar from CACHE. | |
493375cd LC |
463 | (let* ((nar (string-append (string-drop-right narinfo |
464 | (string-length ".narinfo")) | |
465 | ".nar")) | |
466 | (base (basename narinfo ".narinfo")) | |
467 | (hash (string-take base (string-index base #\-))) | |
468 | (mapping (hash-part-mapping-cache-file cache hash))) | |
d72b4206 | 469 | (delete-file* narinfo) |
493375cd LC |
470 | (delete-file* nar) |
471 | (delete-file* mapping))) | |
d72b4206 | 472 | |
b8fa86ad LC |
473 | (let* ((item (hash-part->path* store hash cache)) |
474 | (compressions (actual-compressions item compressions)) | |
475 | (cached (and (not (string-null? item)) | |
476 | (narinfo-cache-file cache item | |
477 | #:compression | |
478 | (first compressions))))) | |
00753f70 LC |
479 | (cond ((string-null? item) |
480 | (not-found request)) | |
481 | ((file-exists? cached) | |
482 | ;; Narinfo is in cache, send it. | |
483 | (values `((content-type . (application/x-nix-narinfo)) | |
484 | ,@(if ttl | |
485 | `((cache-control (max-age . ,ttl))) | |
486 | '())) | |
487 | (lambda (port) | |
488 | (display (call-with-input-file cached | |
489 | read-string) | |
490 | port)))) | |
deac674a LC |
491 | ((and (file-exists? item) ;cheaper than the 'valid-path?' RPC |
492 | (valid-path? store item)) | |
00753f70 LC |
493 | ;; Nothing in cache: bake the narinfo and nar in the background and |
494 | ;; return 404. | |
495 | (eventually pool | |
496 | (single-baker item | |
73739735 LC |
497 | ;; Check whether CACHED has been produced in the meantime. |
498 | (unless (file-exists? cached) | |
499 | ;; (format #t "baking ~s~%" item) | |
500 | (bake-narinfo+nar cache item | |
501 | #:ttl ttl | |
b8fa86ad | 502 | #:compressions compressions |
73739735 | 503 | #:nar-path nar-path))) |
d72b4206 LC |
504 | |
505 | (when ttl | |
506 | (single-baker 'cache-cleanup | |
507 | (maybe-remove-expired-cache-entries cache | |
508 | narinfo-files | |
509 | #:entry-expiration | |
c95644f0 | 510 | (nar-expiration-time ttl) |
d72b4206 LC |
511 | #:delete-entry delete-entry |
512 | #:cleanup-period ttl)))) | |
24b21720 LC |
513 | (not-found request |
514 | #:phrase "We're baking it" | |
515 | #:ttl 300)) ;should be available within 5m | |
00753f70 | 516 | (else |
f3966117 | 517 | (not-found request #:phrase ""))))) |
00753f70 | 518 | |
73bddab5 LC |
519 | (define (compress-nar cache item compression) |
520 | "Save in directory CACHE the nar for ITEM compressed with COMPRESSION." | |
521 | (define nar | |
522 | (nar-cache-file cache item #:compression compression)) | |
523 | ||
524 | (mkdir-p (dirname nar)) | |
525 | (match (compression-type compression) | |
526 | ('gzip | |
527 | ;; Note: the file port gets closed along with the gzip port. | |
528 | (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) | |
529 | (lambda (port) | |
530 | (write-file item port)) | |
531 | #:level (compression-level compression) | |
532 | #:buffer-size (* 128 1024)) | |
533 | (rename-file (string-append nar ".tmp") nar)) | |
534 | ('lzip | |
535 | ;; Note: the file port gets closed along with the lzip port. | |
536 | (call-with-lzip-output-port (open-output-file (string-append nar ".tmp")) | |
537 | (lambda (port) | |
538 | (write-file item port)) | |
539 | #:level (compression-level compression)) | |
540 | (rename-file (string-append nar ".tmp") nar)) | |
541 | ('none | |
542 | ;; Cache nars even when compression is disabled so that we can | |
543 | ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.) | |
544 | (with-atomic-file-output nar | |
545 | (lambda (port) | |
546 | (write-file item port)))))) | |
547 | ||
00753f70 | 548 | (define* (bake-narinfo+nar cache item |
b8fa86ad | 549 | #:key ttl (compressions (list %no-compression)) |
00753f70 LC |
550 | (nar-path "/nar")) |
551 | "Write the narinfo and nar for ITEM to CACHE." | |
b8fa86ad LC |
552 | (define (compressed-nar-size compression) |
553 | (let* ((nar (nar-cache-file cache item #:compression compression)) | |
554 | (stat (stat nar #f))) | |
555 | (and stat | |
556 | (cons compression (stat:size stat))))) | |
557 | ||
558 | (let ((compression (actual-compressions item compressions))) | |
559 | ||
560 | (for-each (cut compress-nar cache item <>) compressions) | |
561 | ||
562 | (match compressions | |
563 | ((main others ...) | |
564 | (let ((narinfo (narinfo-cache-file cache item | |
565 | #:compression main))) | |
566 | (with-atomic-file-output narinfo | |
567 | (lambda (port) | |
568 | ;; Open a new connection to the store. We cannot reuse the main | |
569 | ;; thread's connection to the store since we would end up sending | |
570 | ;; stuff concurrently on the same channel. | |
571 | (with-store store | |
572 | (let ((sizes (filter-map compressed-nar-size compression))) | |
573 | (display (narinfo-string store item | |
574 | (%private-key) | |
575 | #:nar-path nar-path | |
576 | #:compressions compressions | |
577 | #:file-sizes sizes) | |
578 | port))))) | |
579 | ||
580 | ;; Make narinfo files for OTHERS hard links to NARINFO such that the | |
581 | ;; atime-based cache eviction considers either all the nars or none | |
582 | ;; of them as candidates. | |
583 | (for-each (lambda (other) | |
584 | (let ((other (narinfo-cache-file cache item | |
585 | #:compression other))) | |
586 | (link narinfo other))) | |
587 | others)))))) | |
00753f70 | 588 | |
297e04d6 | 589 | ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for |
4a1fc562 LC |
590 | ;; internal consumption: it allows us to pass the compression info to |
591 | ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. | |
297e04d6 | 592 | (declare-header! "X-Nar-Compression" |
4a1fc562 LC |
593 | (lambda (str) |
594 | (match (call-with-input-string str read) | |
595 | (('compression type level) | |
596 | (compression type level)))) | |
597 | compression? | |
598 | (lambda (compression port) | |
599 | (match compression | |
600 | (($ <compression> type level) | |
601 | (write `(compression ,type ,level) port))))) | |
602 | ||
603 | (define* (render-nar store request store-item | |
604 | #:key (compression %no-compression)) | |
aff8ce7c DT |
605 | "Render archive of the store path corresponding to STORE-ITEM." |
606 | (let ((store-path (string-append %store-directory "/" store-item))) | |
607 | ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will | |
608 | ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte | |
609 | ;; sequences. | |
00435580 | 610 | (if (valid-path? store store-path) |
4a1fc562 LC |
611 | (values `((content-type . (application/x-nix-archive |
612 | (charset . "ISO-8859-1"))) | |
297e04d6 | 613 | (x-nar-compression . ,compression)) |
94080a72 LC |
614 | ;; XXX: We're not returning the actual contents, deferring |
615 | ;; instead to 'http-write'. This is a hack to work around | |
616 | ;; <http://bugs.gnu.org/21093>. | |
617 | store-path) | |
aff8ce7c DT |
618 | (not-found request)))) |
619 | ||
00753f70 | 620 | (define* (render-nar/cached store cache request store-item |
9b9de084 | 621 | #:key ttl (compression %no-compression)) |
00753f70 | 622 | "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE, |
9b9de084 LC |
623 | return it; otherwise, return 404. When TTL is true, use it as the |
624 | 'Cache-Control' expiration time." | |
00753f70 LC |
625 | (let ((cached (nar-cache-file cache store-item |
626 | #:compression compression))) | |
627 | (if (file-exists? cached) | |
628 | (values `((content-type . (application/octet-stream | |
152b7bee | 629 | (charset . "ISO-8859-1"))) |
9b9de084 LC |
630 | ,@(if ttl |
631 | `((cache-control (max-age . ,ttl))) | |
632 | '()) | |
633 | ||
152b7bee LC |
634 | ;; XXX: We're not returning the actual contents, deferring |
635 | ;; instead to 'http-write'. This is a hack to work around | |
636 | ;; <http://bugs.gnu.org/21093>. | |
637 | (x-raw-file . ,cached)) | |
638 | #f) | |
00753f70 LC |
639 | (not-found request)))) |
640 | ||
ff6638d1 LC |
641 | (define (render-content-addressed-file store request |
642 | name algo hash) | |
643 | "Return the content of the result of the fixed-output derivation NAME that | |
644 | has the given HASH of type ALGO." | |
645 | ;; TODO: Support other hash algorithms. | |
646 | (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash))) | |
647 | (let ((item (fixed-output-path name hash | |
648 | #:hash-algo algo | |
649 | #:recursive? #f))) | |
650 | (if (valid-path? store item) | |
651 | (values `((content-type . (application/octet-stream | |
152b7bee LC |
652 | (charset . "ISO-8859-1"))) |
653 | ;; XXX: We're not returning the actual contents, | |
654 | ;; deferring instead to 'http-write'. This is a hack to | |
655 | ;; work around <http://bugs.gnu.org/21093>. | |
656 | (x-raw-file . ,item)) | |
657 | #f) | |
ff6638d1 LC |
658 | (not-found request))) |
659 | (not-found request))) | |
660 | ||
c04ffadb LC |
661 | (define (render-log-file store request name) |
662 | "Render the log file for NAME, the base name of a store item. Don't attempt | |
663 | to compress or decompress the log file; just return it as-is." | |
664 | (define (response-headers file) | |
665 | ;; XXX: We're not returning the actual contents, deferring instead to | |
666 | ;; 'http-write'. This is a hack to work around | |
667 | ;; <http://bugs.gnu.org/21093>. | |
668 | (cond ((string-suffix? ".gz" file) | |
669 | `((content-type . (text/plain (charset . "UTF-8"))) | |
670 | (content-encoding . (gzip)) | |
671 | (x-raw-file . ,file))) | |
672 | ((string-suffix? ".bz2" file) | |
673 | `((content-type . (application/x-bzip2 | |
674 | (charset . "ISO-8859-1"))) | |
675 | (x-raw-file . ,file))) | |
676 | (else ;uncompressed | |
677 | `((content-type . (text/plain (charset . "UTF-8"))) | |
678 | (x-raw-file . ,file))))) | |
679 | ||
680 | (let ((log (log-file store | |
681 | (string-append (%store-prefix) "/" name)))) | |
682 | (if log | |
683 | (values (response-headers log) log) | |
684 | (not-found request)))) | |
685 | ||
e1bbc0e3 LC |
686 | (define (render-home-page request) |
687 | "Render the home page." | |
688 | (values `((content-type . (text/html (charset . "UTF-8")))) | |
689 | (call-with-output-string | |
690 | (lambda (port) | |
691 | (sxml->xml '(html | |
692 | (head (title "GNU Guix Substitute Server")) | |
693 | (body | |
694 | (h1 "GNU Guix Substitute Server") | |
695 | (p "Hi, " | |
696 | (a (@ (href | |
3fb3291e | 697 | "https://guix.gnu.org/manual/en/html_node/Invoking-guix-publish.html")) |
e1bbc0e3 LC |
698 | (tt "guix publish")) |
699 | " speaking. Welcome!"))) | |
700 | port))))) | |
701 | ||
33463986 LC |
702 | (define (extract-narinfo-hash str) |
703 | "Return the hash within the narinfo resource string STR, or false if STR | |
aff8ce7c | 704 | is invalid." |
33463986 LC |
705 | (and (string-suffix? ".narinfo" str) |
706 | (let ((base (string-drop-right str 8))) | |
707 | (and (string-every %nix-base32-charset base) | |
708 | base)))) | |
aff8ce7c DT |
709 | |
710 | (define (get-request? request) | |
711 | "Return #t if REQUEST uses the GET method." | |
712 | (eq? (request-method request) 'GET)) | |
713 | ||
714 | (define (request-path-components request) | |
715 | "Split the URI path of REQUEST into a list of component strings. For | |
716 | example: \"/foo/bar\" yields '(\"foo\" \"bar\")." | |
717 | (split-and-decode-uri-path (uri-path (request-uri request)))) | |
718 | ||
7f23fb00 LC |
719 | \f |
720 | ;;; | |
721 | ;;; Server. | |
722 | ;;; | |
723 | ||
724 | (define %http-write | |
725 | (@@ (web server http) http-write)) | |
726 | ||
bb11825f LC |
727 | (match (list (major-version) (minor-version) (micro-version)) |
728 | (("2" "2" "5") ;Guile 2.2.5 | |
729 | (let () | |
730 | (define %read-line (@ (ice-9 rdelim) %read-line)) | |
731 | (define bad-header (@@ (web http) bad-header)) | |
732 | ||
733 | ;; XXX: Work around <https://bugs.gnu.org/36350> by reverting to the | |
734 | ;; definition of 'read-header-line' as found in 2.2.4 and earlier. | |
735 | (define (read-header-line port) | |
736 | "Read an HTTP header line and return it without its final CRLF or LF. | |
737 | Raise a 'bad-header' exception if the line does not end in CRLF or LF, | |
738 | or if EOF is reached." | |
739 | (match (%read-line port) | |
740 | (((? string? line) . #\newline) | |
741 | ;; '%read-line' does not consider #\return a delimiter; so if it's | |
742 | ;; there, remove it. We are more tolerant than the RFC in that we | |
743 | ;; tolerate LF-only endings. | |
744 | (if (string-suffix? "\r" line) | |
745 | (string-drop-right line 1) | |
746 | line)) | |
747 | ((line . _) ;EOF or missing delimiter | |
748 | (bad-header 'read-header-line line)))) | |
749 | ||
750 | (set! (@@ (web http) read-header-line) read-header-line))) | |
751 | (_ #t)) | |
752 | ||
297e04d6 LC |
753 | (define (strip-headers response) |
754 | "Return RESPONSE's headers minus 'Content-Length' and our internal headers." | |
755 | (fold alist-delete | |
756 | (response-headers response) | |
757 | '(content-length x-raw-file x-nar-compression))) | |
758 | ||
94080a72 LC |
759 | (define (sans-content-length response) |
760 | "Return RESPONSE without its 'content-length' header." | |
761 | (set-field response (response-headers) | |
297e04d6 | 762 | (strip-headers response))) |
94080a72 | 763 | |
42d07286 LC |
764 | (define (with-content-length response length) |
765 | "Return RESPONSE with a 'content-length' header set to LENGTH." | |
766 | (set-field response (response-headers) | |
767 | (alist-cons 'content-length length | |
297e04d6 | 768 | (strip-headers response)))) |
42d07286 | 769 | |
cf4e7083 LC |
770 | (define-syntax-rule (swallow-EPIPE exp ...) |
771 | "Swallow EPIPE errors raised by EXP..." | |
772 | (catch 'system-error | |
773 | (lambda () | |
774 | exp ...) | |
775 | (lambda args | |
776 | (if (= EPIPE (system-error-errno args)) | |
777 | (values) | |
778 | (apply throw args))))) | |
779 | ||
4a1fc562 LC |
780 | (define-syntax-rule (swallow-zlib-error exp ...) |
781 | "Swallow 'zlib-error' exceptions raised by EXP..." | |
782 | (catch 'zlib-error | |
783 | (lambda () | |
784 | exp ...) | |
785 | (const #f))) | |
786 | ||
33988f9b | 787 | (define (nar-response-port response compression) |
4a1fc562 LC |
788 | "Return a port on which to write the body of RESPONSE, the response of a |
789 | /nar request, according to COMPRESSION." | |
33988f9b | 790 | (match compression |
4a1fc562 LC |
791 | (($ <compression> 'gzip level) |
792 | ;; Note: We cannot used chunked encoding here because | |
793 | ;; 'make-gzip-output-port' wants a file port. | |
794 | (make-gzip-output-port (response-port response) | |
795 | #:level level | |
796 | #:buffer-size (* 64 1024))) | |
66229b04 LC |
797 | (($ <compression> 'lzip level) |
798 | (make-lzip-output-port (response-port response) | |
799 | #:level level)) | |
4a1fc562 LC |
800 | (($ <compression> 'none) |
801 | (response-port response)) | |
802 | (#f | |
803 | (response-port response)))) | |
804 | ||
7f23fb00 LC |
805 | (define (http-write server client response body) |
806 | "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid | |
807 | blocking." | |
808 | (match (response-content-type response) | |
809 | (('application/x-nix-archive . _) | |
810 | ;; Sending the the whole archive can take time so do it in a separate | |
811 | ;; thread so that the main thread can keep working in the meantime. | |
812 | (call-with-new-thread | |
813 | (lambda () | |
8902d0f2 | 814 | (set-thread-name "publish nar") |
33988f9b LC |
815 | (let* ((compression (assoc-ref (response-headers response) |
816 | 'x-nar-compression)) | |
817 | (response (write-response (sans-content-length response) | |
818 | client)) | |
819 | (port (begin | |
820 | (force-output client) | |
821 | (nar-response-port response compression)))) | |
94080a72 LC |
822 | ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in |
823 | ;; 'render-nar', BODY here is just the file name of the store item. | |
824 | ;; We call 'write-file' from here because we know that's the only | |
825 | ;; way to avoid building the whole nar in memory, which could | |
826 | ;; quickly become a real problem. As a bonus, we even do | |
827 | ;; sendfile(2) directly from the store files to the socket. | |
4a1fc562 LC |
828 | (swallow-zlib-error |
829 | (swallow-EPIPE | |
830 | (write-file (utf8->string body) port))) | |
831 | (swallow-zlib-error | |
832 | (close-port port)) | |
94080a72 | 833 | (values))))) |
7f23fb00 | 834 | (_ |
152b7bee LC |
835 | (match (assoc-ref (response-headers response) 'x-raw-file) |
836 | ((? string? file) | |
837 | ;; Send a raw file in a separate thread. | |
838 | (call-with-new-thread | |
839 | (lambda () | |
840 | (set-thread-name "publish file") | |
841 | (catch 'system-error | |
842 | (lambda () | |
843 | (call-with-input-file file | |
844 | (lambda (input) | |
845 | (let* ((size (stat:size (stat input))) | |
846 | (response (write-response (with-content-length response | |
847 | size) | |
848 | client)) | |
849 | (output (response-port response))) | |
850 | (if (file-port? output) | |
851 | (sendfile output input size) | |
852 | (dump-port input output)) | |
853 | (close-port output) | |
854 | (values))))) | |
855 | (lambda args | |
856 | ;; If the file was GC'd behind our back, that's fine. Likewise if | |
857 | ;; the client closes the connection. | |
858 | (unless (memv (system-error-errno args) | |
859 | (list ENOENT EPIPE ECONNRESET)) | |
860 | (apply throw args)) | |
861 | (values)))))) | |
862 | (#f | |
863 | ;; Handle other responses sequentially. | |
864 | (%http-write server client response body)))))) | |
7f23fb00 LC |
865 | |
866 | (define-server-impl concurrent-http-server | |
867 | ;; A variant of Guile's built-in HTTP server that offloads possibly long | |
868 | ;; responses to a different thread. | |
869 | (@@ (web server http) http-open) | |
870 | (@@ (web server http) http-read) | |
871 | http-write | |
872 | (@@ (web server http) http-close)) | |
873 | ||
66229b04 LC |
874 | (define (string->compression-type string) |
875 | "Return a symbol denoting the compression method expressed by STRING; return | |
876 | #f if STRING doesn't match any supported method." | |
877 | (match string | |
878 | ("gzip" (and (zlib-available?) 'gzip)) | |
879 | ("lzip" (and (lzlib-available?) 'lzip)) | |
880 | (_ #f))) | |
881 | ||
b8fa86ad LC |
882 | (define (effective-compression requested-type compressions) |
883 | "Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION | |
884 | methods, return the applicable compression." | |
885 | (or (find (match-lambda | |
886 | (($ <compression> type) | |
887 | (and (eq? type requested-type) | |
888 | compression))) | |
889 | compressions) | |
890 | (default-compression requested-type))) | |
891 | ||
4a1fc562 LC |
892 | (define* (make-request-handler store |
893 | #:key | |
00753f70 | 894 | cache pool |
4a1fc562 | 895 | narinfo-ttl |
cdd7a7d2 | 896 | (nar-path "nar") |
b8fa86ad | 897 | (compressions (list %no-compression))) |
66229b04 LC |
898 | (define compression-type? |
899 | string->compression-type) | |
900 | ||
cdd7a7d2 LC |
901 | (define nar-path? |
902 | (let ((expected (split-and-decode-uri-path nar-path))) | |
903 | (cut equal? expected <>))) | |
904 | ||
aff8ce7c DT |
905 | (lambda (request body) |
906 | (format #t "~a ~a~%" | |
907 | (request-method request) | |
908 | (uri-path (request-uri request))) | |
ff6638d1 | 909 | (if (get-request? request) ;reject POST, PUT, etc. |
aff8ce7c DT |
910 | (match (request-path-components request) |
911 | ;; /nix-cache-info | |
912 | (("nix-cache-info") | |
913 | (render-nix-cache-info)) | |
e1bbc0e3 LC |
914 | ;; / |
915 | ((or () ("index.html")) | |
916 | (render-home-page request)) | |
aff8ce7c DT |
917 | ;; /<hash>.narinfo |
918 | (((= extract-narinfo-hash (? string? hash))) | |
00753f70 LC |
919 | (if cache |
920 | (render-narinfo/cached store request hash | |
921 | #:cache cache | |
922 | #:pool pool | |
923 | #:ttl narinfo-ttl | |
924 | #:nar-path nar-path | |
b8fa86ad | 925 | #:compressions compressions) |
00753f70 LC |
926 | (render-narinfo store request hash |
927 | #:ttl narinfo-ttl | |
928 | #:nar-path nar-path | |
b8fa86ad | 929 | #:compressions compressions))) |
cdd7a7d2 LC |
930 | ;; /nar/file/NAME/sha256/HASH |
931 | (("file" name "sha256" hash) | |
932 | (guard (c ((invalid-base32-character? c) | |
933 | (not-found request))) | |
934 | (let ((hash (nix-base32-string->bytevector hash))) | |
935 | (render-content-addressed-file store request | |
936 | name 'sha256 hash)))) | |
4a1fc562 | 937 | |
c04ffadb LC |
938 | ;; /log/OUTPUT |
939 | (("log" name) | |
940 | (render-log-file store request name)) | |
941 | ||
4a1fc562 LC |
942 | ;; Use different URLs depending on the compression type. This |
943 | ;; guarantees that /nar URLs remain valid even when 'guix publish' | |
944 | ;; is restarted with different compression parameters. | |
945 | ||
4a1fc562 | 946 | ;; /nar/gzip/<store-item> |
66229b04 LC |
947 | ((components ... (? compression-type? type) store-item) |
948 | (if (nar-path? components) | |
949 | (let* ((compression-type (string->compression-type type)) | |
b8fa86ad LC |
950 | (compression (effective-compression compression-type |
951 | compressions))) | |
00753f70 LC |
952 | (if cache |
953 | (render-nar/cached store cache request store-item | |
9b9de084 | 954 | #:ttl narinfo-ttl |
00753f70 LC |
955 | #:compression compression) |
956 | (render-nar store request store-item | |
957 | #:compression compression))) | |
4a1fc562 | 958 | (not-found request))) |
ff6638d1 | 959 | |
cdd7a7d2 LC |
960 | ;; /nar/<store-item> |
961 | ((components ... store-item) | |
962 | (if (nar-path? components) | |
e5788ebb LC |
963 | (if cache |
964 | (render-nar/cached store cache request store-item | |
9b9de084 | 965 | #:ttl narinfo-ttl |
e5788ebb LC |
966 | #:compression %no-compression) |
967 | (render-nar store request store-item | |
968 | #:compression %no-compression)) | |
cdd7a7d2 LC |
969 | (not-found request))) |
970 | ||
971 | (x (not-found request))) | |
aff8ce7c DT |
972 | (not-found request)))) |
973 | ||
e4c7a5f7 | 974 | (define* (run-publish-server socket store |
b8fa86ad LC |
975 | #:key |
976 | (compressions (list %no-compression)) | |
00753f70 LC |
977 | (nar-path "nar") narinfo-ttl |
978 | cache pool) | |
4a1fc562 | 979 | (run-server (make-request-handler store |
00753f70 LC |
980 | #:cache cache |
981 | #:pool pool | |
cdd7a7d2 | 982 | #:nar-path nar-path |
4a1fc562 | 983 | #:narinfo-ttl narinfo-ttl |
b8fa86ad | 984 | #:compressions compressions) |
7f23fb00 | 985 | concurrent-http-server |
5463fe51 LC |
986 | `(#:socket ,socket))) |
987 | ||
9e2292ef LC |
988 | (define (open-server-socket address) |
989 | "Return a TCP socket bound to ADDRESS, a socket address." | |
990 | (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0))) | |
5463fe51 | 991 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) |
9e2292ef | 992 | (bind sock address) |
5463fe51 LC |
993 | sock)) |
994 | ||
995 | (define (gather-user-privileges user) | |
996 | "Switch to the identity of USER, a user name." | |
997 | (catch 'misc-error | |
998 | (lambda () | |
999 | (let ((user (getpw user))) | |
1000 | (setgroups #()) | |
1001 | (setgid (passwd:gid user)) | |
1002 | (setuid (passwd:uid user)))) | |
1003 | (lambda (key proc message args . rest) | |
69daee23 | 1004 | (leave (G_ "user '~a' not found: ~a~%") |
5463fe51 LC |
1005 | user (apply format #f message args))))) |
1006 | ||
1007 | \f | |
1008 | ;;; | |
1009 | ;;; Entry point. | |
1010 | ;;; | |
aff8ce7c DT |
1011 | |
1012 | (define (guix-publish . args) | |
1013 | (with-error-handling | |
9e2292ef LC |
1014 | (let* ((opts (args-fold* args %options |
1015 | (lambda (opt name arg result) | |
69daee23 | 1016 | (leave (G_ "~A: unrecognized option~%") name)) |
9e2292ef | 1017 | (lambda (arg result) |
69daee23 | 1018 | (leave (G_ "~A: extraneous argument~%") arg)) |
9e2292ef LC |
1019 | %default-options)) |
1020 | (user (assoc-ref opts 'user)) | |
1021 | (port (assoc-ref opts 'port)) | |
e4c7a5f7 | 1022 | (ttl (assoc-ref opts 'narinfo-ttl)) |
b8fa86ad LC |
1023 | (compressions (match (filter-map (match-lambda |
1024 | (('compression . compression) | |
1025 | compression) | |
1026 | (_ #f)) | |
1027 | opts) | |
1028 | (() | |
1029 | ;; Default to fast & low compression. | |
1030 | (list (if (zlib-available?) | |
1031 | %default-gzip-compression | |
1032 | %no-compression))) | |
1033 | (lst (reverse lst)))) | |
9e2292ef LC |
1034 | (address (let ((addr (assoc-ref opts 'address))) |
1035 | (make-socket-address (sockaddr:fam addr) | |
1036 | (sockaddr:addr addr) | |
1037 | port))) | |
1038 | (socket (open-server-socket address)) | |
4bb5e0ae | 1039 | (nar-path (assoc-ref opts 'nar-path)) |
ab2a74e4 | 1040 | (repl-port (assoc-ref opts 'repl)) |
00753f70 LC |
1041 | (cache (assoc-ref opts 'cache)) |
1042 | (workers (assoc-ref opts 'workers)) | |
ab2a74e4 LC |
1043 | |
1044 | ;; Read the key right away so that (1) we fail early on if we can't | |
1045 | ;; access them, and (2) we can then drop privileges. | |
1046 | (public-key (read-file-sexp (assoc-ref opts 'public-key-file))) | |
1047 | (private-key (read-file-sexp (assoc-ref opts 'private-key-file)))) | |
5463fe51 LC |
1048 | |
1049 | (when user | |
1050 | ;; Now that we've read the key material and opened the socket, we can | |
1051 | ;; drop privileges. | |
1052 | (gather-user-privileges user)) | |
1053 | ||
1054 | (when (zero? (getuid)) | |
69daee23 | 1055 | (warning (G_ "server running as root; \ |
5463fe51 | 1056 | consider using the '--user' option!~%"))) |
ab2a74e4 LC |
1057 | |
1058 | (parameterize ((%public-key public-key) | |
1059 | (%private-key private-key)) | |
35d1354f LC |
1060 | (info (G_ "publishing ~a on ~a, port ~d~%") |
1061 | %store-directory | |
1062 | (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) | |
1063 | (sockaddr:port address)) | |
1064 | ||
b8fa86ad LC |
1065 | (for-each (lambda (compression) |
1066 | (info (G_ "using '~a' compression method, level ~a~%") | |
1067 | (compression-type compression) | |
1068 | (compression-level compression))) | |
1069 | compressions) | |
35d1354f | 1070 | |
ab2a74e4 LC |
1071 | (when repl-port |
1072 | (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) | |
8902d0f2 LC |
1073 | |
1074 | ;; Set the name of the main thread. | |
1075 | (set-thread-name "guix publish") | |
1076 | ||
ab2a74e4 LC |
1077 | (with-store store |
1078 | (run-publish-server socket store | |
00753f70 | 1079 | #:cache cache |
8902d0f2 LC |
1080 | #:pool (and cache (make-pool workers |
1081 | #:thread-name | |
1082 | "publish worker")) | |
4bb5e0ae | 1083 | #:nar-path nar-path |
b8fa86ad | 1084 | #:compressions compressions |
ab2a74e4 | 1085 | #:narinfo-ttl ttl)))))) |
00753f70 LC |
1086 | |
1087 | ;;; Local Variables: | |
1088 | ;;; eval: (put 'single-baker 'scheme-indent-function 1) | |
1089 | ;;; End: |