gnu: Properly credit Konrad Hinsen.
[jackhill/guix/guix.git] / tests / publish.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
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 ;; Avoid interference.
21 (unsetenv "http_proxy")
22
23 (define-module (test-publish)
24 #:use-module (guix scripts publish)
25 #:use-module (guix tests)
26 #:use-module (guix config)
27 #:use-module (guix utils)
28 #:use-module (gcrypt hash)
29 #:use-module (guix store)
30 #:use-module (guix derivations)
31 #:use-module (guix gexp)
32 #:use-module (guix base32)
33 #:use-module (guix base64)
34 #:use-module ((guix records) #:select (recutils->alist))
35 #:use-module ((guix serialization) #:select (restore-file))
36 #:use-module (gcrypt pk-crypto)
37 #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
38 #:use-module (zlib)
39 #:use-module (lzlib)
40 #:use-module (web uri)
41 #:use-module (web client)
42 #:use-module (web response)
43 #:use-module (rnrs bytevectors)
44 #:use-module (ice-9 binary-ports)
45 #:use-module (srfi srfi-1)
46 #:use-module (srfi srfi-26)
47 #:use-module (srfi srfi-64)
48 #:use-module (ice-9 threads)
49 #:use-module (ice-9 format)
50 #:use-module (ice-9 match)
51 #:use-module (ice-9 rdelim))
52
53 (define %store
54 (open-connection-for-tests))
55
56 (define %reference (add-text-to-store %store "ref" "foo"))
57
58 (define %item (add-text-to-store %store "item" "bar" (list %reference)))
59
60 (define (http-get-body uri)
61 (call-with-values (lambda () (http-get uri))
62 (lambda (response body) body)))
63
64 (define (http-get-port uri)
65 (let ((socket (open-socket-for-uri uri)))
66 ;; Make sure to use an unbuffered port so that we can then peek at the
67 ;; underlying file descriptor via 'call-with-gzip-input-port'.
68 (setvbuf socket 'none)
69 (call-with-values
70 (lambda ()
71 (http-get uri #:port socket #:streaming? #t))
72 (lambda (response port)
73 ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
74 ;; (PORT might be a custom binary input port).
75 port))))
76
77 (define (publish-uri route)
78 (string-append "http://localhost:6789" route))
79
80 (define-syntax-rule (with-separate-output-ports exp ...)
81 ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
82 ;; error ports to make sure the two threads don't end up stepping on each
83 ;; other's toes.
84 (with-output-to-port (duplicate-port (current-output-port) "w")
85 (lambda ()
86 (with-error-to-port (duplicate-port (current-error-port) "w")
87 (lambda ()
88 exp ...)))))
89
90 ;; Run a local publishing server in a separate thread.
91 (with-separate-output-ports
92 (call-with-new-thread
93 (lambda ()
94 (guix-publish "--port=6789" "-C0")))) ;attempt to avoid port collision
95
96 (define (wait-until-ready port)
97 ;; Wait until the server is accepting connections.
98 (let ((conn (socket PF_INET SOCK_STREAM 0)))
99 (let loop ()
100 (unless (false-if-exception
101 (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
102 (loop)))))
103
104 (define (wait-for-file file)
105 ;; Wait until FILE shows up.
106 (let loop ((i 20))
107 (cond ((file-exists? file)
108 #t)
109 ((zero? i)
110 (error "file didn't show up" file))
111 (else
112 (pk 'wait-for-file file)
113 (sleep 1)
114 (loop (- i 1))))))
115
116 (define %gzip-magic-bytes
117 ;; Magic bytes of gzip file.
118 #vu8(#x1f #x8b))
119
120 ;; Wait until the two servers are ready.
121 (wait-until-ready 6789)
122
123 ;; Initialize the public/private key SRFI-39 parameters.
124 (%public-key (read-file-sexp %public-key-file))
125 (%private-key (read-file-sexp %private-key-file))
126
127 \f
128 (test-begin "publish")
129
130 (test-equal "/nix-cache-info"
131 (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
132 %store-directory)
133 (http-get-body (publish-uri "/nix-cache-info")))
134
135 (test-equal "/*.narinfo"
136 (let* ((info (query-path-info %store %item))
137 (unsigned-info
138 (format #f
139 "StorePath: ~a
140 URL: nar/~a
141 Compression: none
142 FileSize: ~a
143 NarHash: sha256:~a
144 NarSize: ~d
145 References: ~a~%"
146 %item
147 (basename %item)
148 (path-info-nar-size info)
149 (bytevector->nix-base32-string
150 (path-info-hash info))
151 (path-info-nar-size info)
152 (basename (first (path-info-references info)))))
153 (signature (base64-encode
154 (string->utf8
155 (canonical-sexp->string
156 (signed-string unsigned-info))))))
157 (format #f "~aSignature: 1;~a;~a~%"
158 unsigned-info (gethostname) signature))
159 (utf8->string
160 (http-get-body
161 (publish-uri
162 (string-append "/" (store-path-hash-part %item) ".narinfo")))))
163
164 (test-equal "/*.narinfo with properly encoded '+' sign"
165 ;; See <http://bugs.gnu.org/21888>.
166 (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
167 (info (query-path-info %store item))
168 (unsigned-info
169 (format #f
170 "StorePath: ~a
171 URL: nar/~a
172 Compression: none
173 FileSize: ~a
174 NarHash: sha256:~a
175 NarSize: ~d
176 References: ~%"
177 item
178 (uri-encode (basename item))
179 (path-info-nar-size info)
180 (bytevector->nix-base32-string
181 (path-info-hash info))
182 (path-info-nar-size info)))
183 (signature (base64-encode
184 (string->utf8
185 (canonical-sexp->string
186 (signed-string unsigned-info))))))
187 (format #f "~aSignature: 1;~a;~a~%"
188 unsigned-info (gethostname) signature))
189
190 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
191 (utf8->string
192 (http-get-body
193 (publish-uri
194 (string-append "/" (store-path-hash-part item) ".narinfo"))))))
195
196 (test-equal "/nar/*"
197 "bar"
198 (call-with-temporary-output-file
199 (lambda (temp port)
200 (let ((nar (utf8->string
201 (http-get-body
202 (publish-uri
203 (string-append "/nar/" (basename %item)))))))
204 (call-with-input-string nar (cut restore-file <> temp)))
205 (call-with-input-file temp read-string))))
206
207 (test-equal "/nar/gzip/*"
208 "bar"
209 (call-with-temporary-output-file
210 (lambda (temp port)
211 (let ((nar (http-get-port
212 (publish-uri
213 (string-append "/nar/gzip/" (basename %item))))))
214 (call-with-gzip-input-port nar
215 (cut restore-file <> temp)))
216 (call-with-input-file temp read-string))))
217
218 (test-equal "/nar/gzip/* is really gzip"
219 %gzip-magic-bytes
220 ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
221 ;; uncompressed gzip, the test above doesn't check whether it's actually
222 ;; gzip. This is what this test does. See <https://bugs.gnu.org/30184>.
223 (let ((nar (http-get-port
224 (publish-uri
225 (string-append "/nar/gzip/" (basename %item))))))
226 (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
227
228 (test-equal "/nar/lzip/*"
229 "bar"
230 (call-with-temporary-output-file
231 (lambda (temp port)
232 (let ((nar (http-get-port
233 (publish-uri
234 (string-append "/nar/lzip/" (basename %item))))))
235 (call-with-lzip-input-port nar
236 (cut restore-file <> temp)))
237 (call-with-input-file temp read-string))))
238
239 (test-equal "/*.narinfo with compression"
240 `(("StorePath" . ,%item)
241 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
242 ("Compression" . "gzip"))
243 (let ((thread (with-separate-output-ports
244 (call-with-new-thread
245 (lambda ()
246 (guix-publish "--port=6799" "-C5"))))))
247 (wait-until-ready 6799)
248 (let* ((url (string-append "http://localhost:6799/"
249 (store-path-hash-part %item) ".narinfo"))
250 (body (http-get-port url)))
251 (filter (lambda (item)
252 (match item
253 (("Compression" . _) #t)
254 (("StorePath" . _) #t)
255 (("URL" . _) #t)
256 (_ #f)))
257 (recutils->alist body)))))
258
259 (test-equal "/*.narinfo with lzip compression"
260 `(("StorePath" . ,%item)
261 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
262 ("Compression" . "lzip"))
263 (let ((thread (with-separate-output-ports
264 (call-with-new-thread
265 (lambda ()
266 (guix-publish "--port=6790" "-Clzip"))))))
267 (wait-until-ready 6790)
268 (let* ((url (string-append "http://localhost:6790/"
269 (store-path-hash-part %item) ".narinfo"))
270 (body (http-get-port url)))
271 (filter (lambda (item)
272 (match item
273 (("Compression" . _) #t)
274 (("StorePath" . _) #t)
275 (("URL" . _) #t)
276 (_ #f)))
277 (recutils->alist body)))))
278
279 (test-equal "/*.narinfo for a compressed file"
280 '("none" "nar") ;compression-less nar
281 ;; Assume 'guix publish -C' is already running on port 6799.
282 (let* ((item (add-text-to-store %store "fake.tar.gz"
283 "This is a fake compressed file."))
284 (url (string-append "http://localhost:6799/"
285 (store-path-hash-part item) ".narinfo"))
286 (body (http-get-port url))
287 (info (recutils->alist body)))
288 (list (assoc-ref info "Compression")
289 (dirname (assoc-ref info "URL")))))
290
291 (test-equal "/*.narinfo with lzip + gzip"
292 `((("StorePath" . ,%item)
293 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
294 ("Compression" . "gzip")
295 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
296 ("Compression" . "lzip"))
297 200
298 200)
299 (call-with-temporary-directory
300 (lambda (cache)
301 (let ((thread (with-separate-output-ports
302 (call-with-new-thread
303 (lambda ()
304 (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
305 (wait-until-ready 6793)
306 (let* ((base "http://localhost:6793/")
307 (part (store-path-hash-part %item))
308 (url (string-append base part ".narinfo"))
309 (body (http-get-port url)))
310 (list (take (recutils->alist body) 5)
311 (response-code
312 (http-get (string-append base "nar/gzip/"
313 (basename %item))))
314 (response-code
315 (http-get (string-append base "nar/lzip/"
316 (basename %item))))))))))
317
318 (test-equal "custom nar path"
319 ;; Serve nars at /foo/bar/chbouib instead of /nar.
320 (list `(("StorePath" . ,%item)
321 ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
322 ("Compression" . "none"))
323 200
324 404)
325 (let ((thread (with-separate-output-ports
326 (call-with-new-thread
327 (lambda ()
328 (guix-publish "--port=6798" "-C0"
329 "--nar-path=///foo/bar//chbouib/"))))))
330 (wait-until-ready 6798)
331 (let* ((base "http://localhost:6798/")
332 (part (store-path-hash-part %item))
333 (url (string-append base part ".narinfo"))
334 (nar-url (string-append base "foo/bar/chbouib/"
335 (basename %item)))
336 (body (http-get-port url)))
337 (list (filter (lambda (item)
338 (match item
339 (("Compression" . _) #t)
340 (("StorePath" . _) #t)
341 (("URL" . _) #t)
342 (_ #f)))
343 (recutils->alist body))
344 (response-code (http-get nar-url))
345 (response-code
346 (http-get (string-append base "nar/" (basename %item))))))))
347
348 (test-equal "/nar/ with properly encoded '+' sign"
349 "Congrats!"
350 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
351 (call-with-temporary-output-file
352 (lambda (temp port)
353 (let ((nar (utf8->string
354 (http-get-body
355 (publish-uri
356 (string-append "/nar/" (uri-encode (basename item))))))))
357 (call-with-input-string nar (cut restore-file <> temp)))
358 (call-with-input-file temp read-string)))))
359
360 (test-equal "/nar/invalid"
361 404
362 (begin
363 (call-with-output-file (string-append (%store-prefix) "/invalid")
364 (lambda (port)
365 (display "This file is not a valid store item." port)))
366 (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))
367
368 (test-equal "/file/NAME/sha256/HASH"
369 "Hello, Guix world!"
370 (let* ((data "Hello, Guix world!")
371 (hash (call-with-input-string data port-sha256))
372 (drv (run-with-store %store
373 (gexp->derivation "the-file.txt"
374 #~(call-with-output-file #$output
375 (lambda (port)
376 (display #$data port)))
377 #:hash-algo 'sha256
378 #:hash hash)))
379 (out (build-derivations %store (list drv))))
380 (utf8->string
381 (http-get-body
382 (publish-uri
383 (string-append "/file/the-file.txt/sha256/"
384 (bytevector->nix-base32-string hash)))))))
385
386 (test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
387 404
388 (let ((uri (publish-uri
389 "/file/the-file.txt/sha256/not-a-nix-base32-string")))
390 (response-code (http-get uri))))
391
392 (test-equal "/file/NAME/sha256/INVALID-HASH"
393 404
394 (let ((uri (publish-uri
395 (string-append "/file/the-file.txt/sha256/"
396 (bytevector->nix-base32-string
397 (call-with-input-string "" port-sha256))))))
398 (response-code (http-get uri))))
399
400 (test-equal "with cache"
401 (list #t
402 `(("StorePath" . ,%item)
403 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
404 ("Compression" . "gzip"))
405 200 ;nar/gzip/…
406 #t ;Content-Length
407 #t ;FileSize
408 404) ;nar/…
409 (call-with-temporary-directory
410 (lambda (cache)
411 (let ((thread (with-separate-output-ports
412 (call-with-new-thread
413 (lambda ()
414 (guix-publish "--port=6797" "-C2"
415 (string-append "--cache=" cache)))))))
416 (wait-until-ready 6797)
417 (let* ((base "http://localhost:6797/")
418 (part (store-path-hash-part %item))
419 (url (string-append base part ".narinfo"))
420 (nar-url (string-append base "nar/gzip/" (basename %item)))
421 (cached (string-append cache "/gzip/" (basename %item)
422 ".narinfo"))
423 (nar (string-append cache "/gzip/"
424 (basename %item) ".nar"))
425 (response (http-get url)))
426 (and (= 404 (response-code response))
427
428 ;; We should get an explicitly short TTL for 404 in this case
429 ;; because it's going to become 200 shortly.
430 (match (assq-ref (response-headers response) 'cache-control)
431 ((('max-age . ttl))
432 (< ttl 3600)))
433
434 (wait-for-file cached)
435 (let* ((body (http-get-port url))
436 (compressed (http-get nar-url))
437 (uncompressed (http-get (string-append base "nar/"
438 (basename %item))))
439 (narinfo (recutils->alist body)))
440 (list (file-exists? nar)
441 (filter (lambda (item)
442 (match item
443 (("Compression" . _) #t)
444 (("StorePath" . _) #t)
445 (("URL" . _) #t)
446 (_ #f)))
447 narinfo)
448 (response-code compressed)
449 (= (response-content-length compressed)
450 (stat:size (stat nar)))
451 (= (string->number
452 (assoc-ref narinfo "FileSize"))
453 (stat:size (stat nar)))
454 (response-code uncompressed)))))))))
455
456 (test-equal "with cache, lzip + gzip"
457 '(200 200 404)
458 (call-with-temporary-directory
459 (lambda (cache)
460 (let ((thread (with-separate-output-ports
461 (call-with-new-thread
462 (lambda ()
463 (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
464 (string-append "--cache=" cache)))))))
465 (wait-until-ready 6794)
466 (let* ((base "http://localhost:6794/")
467 (part (store-path-hash-part %item))
468 (url (string-append base part ".narinfo"))
469 (nar-url (cute string-append "nar/" <> "/"
470 (basename %item)))
471 (cached (cute string-append cache "/" <> "/"
472 (basename %item) ".narinfo"))
473 (nar (cute string-append cache "/" <> "/"
474 (basename %item) ".nar"))
475 (response (http-get url)))
476 (wait-for-file (cached "gzip"))
477 (let* ((body (http-get-port url))
478 (narinfo (recutils->alist body))
479 (uncompressed (string-append base "nar/"
480 (basename %item))))
481 (and (file-exists? (nar "gzip"))
482 (file-exists? (nar "lzip"))
483 (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
484 `(("StorePath" . ,%item)
485 ("URL" . ,(nar-url "gzip"))
486 ("Compression" . "gzip")
487 ("FileSize" . ,(number->string
488 (stat:size (stat (nar "gzip")))))
489 ("URL" . ,(nar-url "lzip"))
490 ("Compression" . "lzip")
491 ("FileSize" . ,(number->string
492 (stat:size (stat (nar "lzip")))))))
493 (list (response-code
494 (http-get (string-append base (nar-url "gzip"))))
495 (response-code
496 (http-get (string-append base (nar-url "lzip"))))
497 (response-code
498 (http-get uncompressed))))))))))
499
500 (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
501 (random-text))))
502 (test-equal "with cache, uncompressed"
503 (list #t
504 (* 42 3600) ;TTL on narinfo
505 `(("StorePath" . ,item)
506 ("URL" . ,(string-append "nar/" (basename item)))
507 ("Compression" . "none"))
508 200 ;nar/…
509 (* 42 3600) ;TTL on nar/…
510 (path-info-nar-size
511 (query-path-info %store item)) ;FileSize
512 404) ;nar/gzip/…
513 (call-with-temporary-directory
514 (lambda (cache)
515 (let ((thread (with-separate-output-ports
516 (call-with-new-thread
517 (lambda ()
518 (guix-publish "--port=6796" "-C2" "--ttl=42h"
519 (string-append "--cache=" cache)))))))
520 (wait-until-ready 6796)
521 (let* ((base "http://localhost:6796/")
522 (part (store-path-hash-part item))
523 (url (string-append base part ".narinfo"))
524 (cached (string-append cache "/none/"
525 (basename item) ".narinfo"))
526 (nar (string-append cache "/none/"
527 (basename item) ".nar"))
528 (response (http-get url)))
529 (and (= 404 (response-code response))
530
531 (wait-for-file cached)
532 (let* ((response (http-get url))
533 (body (http-get-port url))
534 (compressed (http-get (string-append base "nar/gzip/"
535 (basename item))))
536 (uncompressed (http-get (string-append base "nar/"
537 (basename item))))
538 (narinfo (recutils->alist body)))
539 (list (file-exists? nar)
540 (match (assq-ref (response-headers response)
541 'cache-control)
542 ((('max-age . ttl)) ttl)
543 (_ #f))
544
545 (filter (lambda (item)
546 (match item
547 (("Compression" . _) #t)
548 (("StorePath" . _) #t)
549 (("URL" . _) #t)
550 (_ #f)))
551 narinfo)
552 (response-code uncompressed)
553 (match (assq-ref (response-headers uncompressed)
554 'cache-control)
555 ((('max-age . ttl)) ttl)
556 (_ #f))
557
558 (string->number
559 (assoc-ref narinfo "FileSize"))
560 (response-code compressed))))))))))
561
562 (test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897>
563 200
564 (call-with-temporary-directory
565 (lambda (cache)
566 (let ((thread (with-separate-output-ports
567 (call-with-new-thread
568 (lambda ()
569 (guix-publish "--port=6795"
570 (string-append "--cache=" cache)))))))
571 (wait-until-ready 6795)
572
573 ;; Make sure that, even if ITEM disappears, we're still able to fetch
574 ;; it.
575 (let* ((base "http://localhost:6795/")
576 (item (add-text-to-store %store "random" (random-text)))
577 (part (store-path-hash-part item))
578 (url (string-append base part ".narinfo"))
579 (cached (string-append cache "/gzip/"
580 (basename item)
581 ".narinfo"))
582 (response (http-get url)))
583 (and (= 404 (response-code response))
584 (wait-for-file cached)
585 (begin
586 (delete-paths %store (list item))
587 (response-code (pk 'response (http-get url))))))))))
588
589 (test-equal "/log/NAME"
590 `(200 #t application/x-bzip2)
591 (let ((drv (run-with-store %store
592 (gexp->derivation "with-log"
593 #~(call-with-output-file #$output
594 (lambda (port)
595 (display "Hello, build log!"
596 (current-error-port))
597 (display #$(random-text) port)))))))
598 (build-derivations %store (list drv))
599 (let* ((response (http-get
600 (publish-uri (string-append "/log/"
601 (basename (derivation->output-path drv))))
602 #:decode-body? #f))
603 (base (basename (derivation-file-name drv)))
604 (log (string-append (dirname %state-directory)
605 "/log/guix/drvs/" (string-take base 2)
606 "/" (string-drop base 2) ".bz2")))
607 (list (response-code response)
608 (= (response-content-length response) (stat:size (stat log)))
609 (first (response-content-type response))))))
610
611 (test-equal "/log/NAME not found"
612 404
613 (let ((uri (publish-uri "/log/does-not-exist")))
614 (response-code (http-get uri))))
615
616 (test-equal "non-GET query"
617 '(200 404)
618 (let ((path (string-append "/" (store-path-hash-part %item)
619 ".narinfo")))
620 (map response-code
621 (list (http-get (publish-uri path))
622 (http-post (publish-uri path))))))
623
624 (test-end "publish")