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