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