1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
4 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 ;; Avoid interference.
22 (unsetenv "http_proxy")
24 (define-module (test-publish)
25 #:use-module (guix scripts publish)
26 #:use-module (guix tests)
27 #:use-module (guix config)
28 #:use-module (guix utils)
29 #:use-module (gcrypt hash)
30 #:use-module (guix store)
31 #:use-module (guix derivations)
32 #:use-module (guix gexp)
33 #:use-module (guix base32)
34 #:use-module (guix base64)
35 #:use-module ((guix records) #:select (recutils->alist))
36 #:use-module ((guix serialization) #:select (restore-file))
37 #:use-module (gcrypt pk-crypto)
38 #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
41 #:use-module (web uri)
42 #:use-module (web client)
43 #:use-module (web response)
44 #:use-module (rnrs bytevectors)
45 #:use-module (ice-9 binary-ports)
46 #:use-module (srfi srfi-1)
47 #:use-module (srfi srfi-26)
48 #:use-module (srfi srfi-64)
49 #:use-module (ice-9 threads)
50 #:use-module (ice-9 format)
51 #:use-module (ice-9 match)
52 #:use-module (ice-9 rdelim))
55 (open-connection-for-tests))
57 (define %reference (add-text-to-store %store "ref" "foo"))
59 (define %item (add-text-to-store %store "item" "bar" (list %reference)))
61 (define (http-get-body uri)
62 (call-with-values (lambda () (http-get uri))
63 (lambda (response body) body)))
65 (define (http-get-port uri)
66 (let ((socket (open-socket-for-uri uri)))
67 ;; Make sure to use an unbuffered port so that we can then peek at the
68 ;; underlying file descriptor via 'call-with-gzip-input-port'.
69 (setvbuf socket 'none)
72 (http-get uri #:port socket #:streaming? #t))
73 (lambda (response port)
74 ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
75 ;; (PORT might be a custom binary input port).
78 (define (publish-uri route)
79 (string-append "http://localhost:6789" route))
81 (define-syntax-rule (with-separate-output-ports exp ...)
82 ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
83 ;; error ports to make sure the two threads don't end up stepping on each
85 (with-output-to-port (duplicate-port (current-output-port) "w")
87 (with-error-to-port (duplicate-port (current-error-port) "w")
91 ;; Run a local publishing server in a separate thread.
92 (with-separate-output-ports
95 (guix-publish "--port=6789" "-C0")))) ;attempt to avoid port collision
97 (define (wait-until-ready port)
98 ;; Wait until the server is accepting connections.
99 (let ((conn (socket PF_INET SOCK_STREAM 0)))
101 (unless (false-if-exception
102 (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
105 (define (wait-for-file file)
106 ;; Wait until FILE shows up.
108 (cond ((file-exists? file)
111 (error "file didn't show up" file))
113 (pk 'wait-for-file file)
117 (define %gzip-magic-bytes
118 ;; Magic bytes of gzip file.
121 ;; Wait until the two servers are ready.
122 (wait-until-ready 6789)
124 ;; Initialize the public/private key SRFI-39 parameters.
125 (%public-key (read-file-sexp %public-key-file))
126 (%private-key (read-file-sexp %private-key-file))
129 (test-begin "publish")
131 (test-equal "/nix-cache-info"
132 (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
134 (http-get-body (publish-uri "/nix-cache-info")))
136 (test-equal "/*.narinfo"
137 (let* ((info (query-path-info %store %item))
149 (path-info-nar-size info)
150 (bytevector->nix-base32-string
151 (path-info-hash info))
152 (path-info-nar-size info)
153 (basename (first (path-info-references info)))))
154 (signature (base64-encode
156 (canonical-sexp->string
157 (signed-string unsigned-info))))))
158 (format #f "~aSignature: 1;~a;~a~%"
159 unsigned-info (gethostname) signature))
163 (string-append "/" (store-path-hash-part %item) ".narinfo")))))
165 (test-equal "/*.narinfo with properly encoded '+' sign"
166 ;; See <http://bugs.gnu.org/21888>.
167 (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
168 (info (query-path-info %store item))
179 (uri-encode (basename item))
180 (path-info-nar-size info)
181 (bytevector->nix-base32-string
182 (path-info-hash info))
183 (path-info-nar-size info)))
184 (signature (base64-encode
186 (canonical-sexp->string
187 (signed-string unsigned-info))))))
188 (format #f "~aSignature: 1;~a;~a~%"
189 unsigned-info (gethostname) signature))
191 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
195 (string-append "/" (store-path-hash-part item) ".narinfo"))))))
199 (call-with-temporary-output-file
201 (let ((nar (utf8->string
204 (string-append "/nar/" (basename %item)))))))
205 (call-with-input-string nar (cut restore-file <> temp)))
206 (call-with-input-file temp read-string))))
208 (test-equal "/nar/gzip/*"
210 (call-with-temporary-output-file
212 (let ((nar (http-get-port
214 (string-append "/nar/gzip/" (basename %item))))))
215 (call-with-gzip-input-port nar
216 (cut restore-file <> temp)))
217 (call-with-input-file temp read-string))))
219 (test-equal "/nar/gzip/* is really gzip"
221 ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
222 ;; uncompressed gzip, the test above doesn't check whether it's actually
223 ;; gzip. This is what this test does. See <https://bugs.gnu.org/30184>.
224 (let ((nar (http-get-port
226 (string-append "/nar/gzip/" (basename %item))))))
227 (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
229 (test-equal "/nar/lzip/*"
231 (call-with-temporary-output-file
233 (let ((nar (http-get-port
235 (string-append "/nar/lzip/" (basename %item))))))
236 (call-with-lzip-input-port nar
237 (cut restore-file <> temp)))
238 (call-with-input-file temp read-string))))
240 (test-equal "/*.narinfo with compression"
241 `(("StorePath" . ,%item)
242 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
243 ("Compression" . "gzip"))
244 (let ((thread (with-separate-output-ports
245 (call-with-new-thread
247 (guix-publish "--port=6799" "-C5"))))))
248 (wait-until-ready 6799)
249 (let* ((url (string-append "http://localhost:6799/"
250 (store-path-hash-part %item) ".narinfo"))
251 (body (http-get-port url)))
252 (filter (lambda (item)
254 (("Compression" . _) #t)
255 (("StorePath" . _) #t)
258 (recutils->alist body)))))
260 (test-equal "/*.narinfo with lzip compression"
261 `(("StorePath" . ,%item)
262 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
263 ("Compression" . "lzip"))
264 (let ((thread (with-separate-output-ports
265 (call-with-new-thread
267 (guix-publish "--port=6790" "-Clzip"))))))
268 (wait-until-ready 6790)
269 (let* ((url (string-append "http://localhost:6790/"
270 (store-path-hash-part %item) ".narinfo"))
271 (body (http-get-port url)))
272 (filter (lambda (item)
274 (("Compression" . _) #t)
275 (("StorePath" . _) #t)
278 (recutils->alist body)))))
280 (test-equal "/*.narinfo for a compressed file"
281 '("none" "nar") ;compression-less nar
282 ;; Assume 'guix publish -C' is already running on port 6799.
283 (let* ((item (add-text-to-store %store "fake.tar.gz"
284 "This is a fake compressed file."))
285 (url (string-append "http://localhost:6799/"
286 (store-path-hash-part item) ".narinfo"))
287 (body (http-get-port url))
288 (info (recutils->alist body)))
289 (list (assoc-ref info "Compression")
290 (dirname (assoc-ref info "URL")))))
292 (test-equal "/*.narinfo with lzip + gzip"
293 `((("StorePath" . ,%item)
294 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
295 ("Compression" . "gzip")
296 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
297 ("Compression" . "lzip"))
300 (call-with-temporary-directory
302 (let ((thread (with-separate-output-ports
303 (call-with-new-thread
305 (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
306 (wait-until-ready 6793)
307 (let* ((base "http://localhost:6793/")
308 (part (store-path-hash-part %item))
309 (url (string-append base part ".narinfo"))
310 (body (http-get-port url)))
311 (list (take (recutils->alist body) 5)
313 (http-get (string-append base "nar/gzip/"
316 (http-get (string-append base "nar/lzip/"
317 (basename %item))))))))))
319 (test-equal "custom nar path"
320 ;; Serve nars at /foo/bar/chbouib instead of /nar.
321 (list `(("StorePath" . ,%item)
322 ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
323 ("Compression" . "none"))
326 (let ((thread (with-separate-output-ports
327 (call-with-new-thread
329 (guix-publish "--port=6798" "-C0"
330 "--nar-path=///foo/bar//chbouib/"))))))
331 (wait-until-ready 6798)
332 (let* ((base "http://localhost:6798/")
333 (part (store-path-hash-part %item))
334 (url (string-append base part ".narinfo"))
335 (nar-url (string-append base "foo/bar/chbouib/"
337 (body (http-get-port url)))
338 (list (filter (lambda (item)
340 (("Compression" . _) #t)
341 (("StorePath" . _) #t)
344 (recutils->alist body))
345 (response-code (http-get nar-url))
347 (http-get (string-append base "nar/" (basename %item))))))))
349 (test-equal "/nar/ with properly encoded '+' sign"
351 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
352 (call-with-temporary-output-file
354 (let ((nar (utf8->string
357 (string-append "/nar/" (uri-encode (basename item))))))))
358 (call-with-input-string nar (cut restore-file <> temp)))
359 (call-with-input-file temp read-string)))))
361 (test-equal "/nar/invalid"
364 (call-with-output-file (string-append (%store-prefix) "/invalid")
366 (display "This file is not a valid store item." port)))
367 (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))
369 (test-equal "/file/NAME/sha256/HASH"
371 (let* ((data "Hello, Guix world!")
372 (hash (call-with-input-string data port-sha256))
373 (drv (run-with-store %store
374 (gexp->derivation "the-file.txt"
375 #~(call-with-output-file #$output
377 (display #$data port)))
380 (out (build-derivations %store (list drv))))
384 (string-append "/file/the-file.txt/sha256/"
385 (bytevector->nix-base32-string hash)))))))
387 (test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
389 (let ((uri (publish-uri
390 "/file/the-file.txt/sha256/not-a-nix-base32-string")))
391 (response-code (http-get uri))))
393 (test-equal "/file/NAME/sha256/INVALID-HASH"
395 (let ((uri (publish-uri
396 (string-append "/file/the-file.txt/sha256/"
397 (bytevector->nix-base32-string
398 (call-with-input-string "" port-sha256))))))
399 (response-code (http-get uri))))
401 (test-equal "with cache"
403 `(("StorePath" . ,%item)
404 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
405 ("Compression" . "gzip"))
410 (call-with-temporary-directory
412 (let ((thread (with-separate-output-ports
413 (call-with-new-thread
415 (guix-publish "--port=6797" "-C2"
416 (string-append "--cache=" cache)
417 "--cache-bypass-threshold=0"))))))
418 (wait-until-ready 6797)
419 (let* ((base "http://localhost:6797/")
420 (part (store-path-hash-part %item))
421 (url (string-append base part ".narinfo"))
422 (nar-url (string-append base "nar/gzip/" (basename %item)))
423 (cached (string-append cache "/gzip/" (basename %item)
425 (nar (string-append cache "/gzip/"
426 (basename %item) ".nar"))
427 (response (http-get url)))
428 (and (= 404 (response-code response))
430 ;; We should get an explicitly short TTL for 404 in this case
431 ;; because it's going to become 200 shortly.
432 (match (assq-ref (response-headers response) 'cache-control)
436 (wait-for-file cached)
438 ;; Both the narinfo and nar should be world-readable.
439 (= #o644 (stat:perms (lstat cached)))
440 (= #o644 (stat:perms (lstat nar)))
442 (let* ((body (http-get-port url))
443 (compressed (http-get nar-url))
444 (uncompressed (http-get (string-append base "nar/"
446 (narinfo (recutils->alist body)))
447 (list (file-exists? nar)
448 (filter (lambda (item)
450 (("Compression" . _) #t)
451 (("StorePath" . _) #t)
455 (response-code compressed)
456 (= (response-content-length compressed)
457 (stat:size (stat nar)))
459 (assoc-ref narinfo "FileSize"))
460 (stat:size (stat nar)))
461 (response-code uncompressed)))))))))
463 (test-equal "with cache, lzip + gzip"
465 (call-with-temporary-directory
467 (let ((thread (with-separate-output-ports
468 (call-with-new-thread
470 (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
471 (string-append "--cache=" cache)
472 "--cache-bypass-threshold=0"))))))
473 (wait-until-ready 6794)
474 (let* ((base "http://localhost:6794/")
475 (part (store-path-hash-part %item))
476 (url (string-append base part ".narinfo"))
477 (nar-url (cute string-append "nar/" <> "/"
479 (cached (cute string-append cache "/" <> "/"
480 (basename %item) ".narinfo"))
481 (nar (cute string-append cache "/" <> "/"
482 (basename %item) ".nar"))
483 (response (http-get url)))
484 (wait-for-file (cached "gzip"))
485 (let* ((body (http-get-port url))
486 (narinfo (recutils->alist body))
487 (uncompressed (string-append base "nar/"
489 (and (file-exists? (nar "gzip"))
490 (file-exists? (nar "lzip"))
491 (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
492 `(("StorePath" . ,%item)
493 ("URL" . ,(nar-url "gzip"))
494 ("Compression" . "gzip")
495 ("FileSize" . ,(number->string
496 (stat:size (stat (nar "gzip")))))
497 ("URL" . ,(nar-url "lzip"))
498 ("Compression" . "lzip")
499 ("FileSize" . ,(number->string
500 (stat:size (stat (nar "lzip")))))))
502 (http-get (string-append base (nar-url "gzip"))))
504 (http-get (string-append base (nar-url "lzip"))))
506 (http-get uncompressed))))))))))
508 (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
510 (test-equal "with cache, uncompressed"
512 (* 42 3600) ;TTL on narinfo
513 `(("StorePath" . ,item)
514 ("URL" . ,(string-append "nar/" (basename item)))
515 ("Compression" . "none"))
517 (* 42 3600) ;TTL on nar/…
519 (query-path-info %store item)) ;FileSize
521 (call-with-temporary-directory
523 (let ((thread (with-separate-output-ports
524 (call-with-new-thread
526 (guix-publish "--port=6796" "-C2" "--ttl=42h"
527 (string-append "--cache=" cache)
528 "--cache-bypass-threshold=0"))))))
529 (wait-until-ready 6796)
530 (let* ((base "http://localhost:6796/")
531 (part (store-path-hash-part item))
532 (url (string-append base part ".narinfo"))
533 (cached (string-append cache "/none/"
534 (basename item) ".narinfo"))
535 (nar (string-append cache "/none/"
536 (basename item) ".nar"))
537 (response (http-get url)))
538 (and (= 404 (response-code response))
540 (wait-for-file cached)
541 (let* ((response (http-get url))
542 (body (http-get-port url))
543 (compressed (http-get (string-append base "nar/gzip/"
545 (uncompressed (http-get (string-append base "nar/"
547 (narinfo (recutils->alist body)))
548 (list (file-exists? nar)
549 (match (assq-ref (response-headers response)
551 ((('max-age . ttl)) ttl)
554 (filter (lambda (item)
556 (("Compression" . _) #t)
557 (("StorePath" . _) #t)
561 (response-code uncompressed)
562 (match (assq-ref (response-headers uncompressed)
564 ((('max-age . ttl)) ttl)
568 (assoc-ref narinfo "FileSize"))
569 (response-code compressed))))))))))
571 (test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897>
573 (call-with-temporary-directory
575 (let ((thread (with-separate-output-ports
576 (call-with-new-thread
578 (guix-publish "--port=6795"
579 (string-append "--cache=" cache)))))))
580 (wait-until-ready 6795)
582 ;; Make sure that, even if ITEM disappears, we're still able to fetch
584 (let* ((base "http://localhost:6795/")
585 (item (add-text-to-store %store "random" (random-text)))
586 (part (store-path-hash-part item))
587 (url (string-append base part ".narinfo"))
588 (cached (string-append cache "/gzip/"
591 (response (http-get url)))
592 (and (= 200 (response-code response)) ;we're below the threshold
593 (wait-for-file cached)
595 (delete-paths %store (list item))
596 (response-code (pk 'response (http-get url))))))))))
598 (test-equal "with cache, cache bypass"
600 (call-with-temporary-directory
602 (let ((thread (with-separate-output-ports
603 (call-with-new-thread
605 (guix-publish "--port=6788" "-C" "gzip"
606 (string-append "--cache=" cache)))))))
607 (wait-until-ready 6788)
609 (let* ((base "http://localhost:6788/")
610 (item (add-text-to-store %store "random" (random-text)))
611 (part (store-path-hash-part item))
612 (narinfo (string-append base part ".narinfo"))
613 (nar (string-append base "nar/gzip/" (basename item)))
614 (cached (string-append cache "/gzip/" (basename item)
616 ;; We're below the default cache bypass threshold, so NAR and NARINFO
617 ;; should immediately return 200. The NARINFO request should trigger
618 ;; caching, and the next request to NAR should return 200 as well.
619 (and (let ((response (pk 'r1 (http-get nar))))
620 (and (= 200 (response-code response))
621 (not (response-content-length response)))) ;not known
622 (= 200 (response-code (http-get narinfo)))
624 (wait-for-file cached)
625 (let ((response (pk 'r2 (http-get nar))))
626 (and (> (response-content-length response)
627 (stat:size (stat item)))
628 (response-code response))))))))))
630 (test-equal "with cache, cache bypass, unmapped hash part"
633 ;; This test reproduces the bug described in <https://bugs.gnu.org/44442>:
634 ;; the daemon connection would be closed as a side effect of a nar request
635 ;; for a non-existing file name.
636 (call-with-temporary-directory
638 (let ((thread (with-separate-output-ports
639 (call-with-new-thread
641 (guix-publish "--port=6787" "-C" "gzip"
642 (string-append "--cache=" cache)))))))
643 (wait-until-ready 6787)
645 (let* ((base "http://localhost:6787/")
646 (item (add-text-to-store %store "random" (random-text)))
647 (part (store-path-hash-part item))
648 (narinfo (string-append base part ".narinfo"))
649 (nar (string-append base "nar/gzip/" (basename item)))
650 (cached (string-append cache "/gzip/" (basename item)
652 ;; The first response used to be 500 and to terminate the daemon
653 ;; connection as a side effect.
654 (and (= (response-code
655 (http-get (string-append base "nar/gzip/"
659 (= 200 (response-code (http-get nar)))
660 (= 200 (response-code (http-get narinfo)))
662 (wait-for-file cached)
663 (response-code (http-get nar)))))))))
665 (test-equal "/log/NAME"
666 `(200 #t application/x-bzip2)
667 (let ((drv (run-with-store %store
668 (gexp->derivation "with-log"
669 #~(call-with-output-file #$output
671 (display "Hello, build log!"
672 (current-error-port))
673 (display #$(random-text) port)))))))
674 (build-derivations %store (list drv))
675 (let* ((response (http-get
676 (publish-uri (string-append "/log/"
677 (basename (derivation->output-path drv))))
679 (base (basename (derivation-file-name drv)))
680 (log (string-append (dirname %state-directory)
681 "/log/guix/drvs/" (string-take base 2)
682 "/" (string-drop base 2) ".bz2")))
683 (list (response-code response)
684 (= (response-content-length response) (stat:size (stat log)))
685 (first (response-content-type response))))))
687 (test-equal "/log/NAME not found"
689 (let ((uri (publish-uri "/log/does-not-exist")))
690 (response-code (http-get uri))))
692 (test-equal "/signing-key.pub"
694 (response-code (http-get (publish-uri "/signing-key.pub"))))
696 (test-equal "non-GET query"
698 (let ((path (string-append "/" (store-path-hash-part %item)
701 (list (http-get (publish-uri path))
702 (http-post (publish-uri path))))))