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-2022 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 #:autoload (zstd) (call-with-zstd-input-port)
42 #:use-module (web uri)
43 #:use-module (web client)
44 #:use-module (web request)
45 #:use-module (web response)
46 #:use-module ((guix http-client) #:select (http-multiple-get))
47 #:use-module (rnrs bytevectors)
48 #:use-module (ice-9 binary-ports)
49 #:use-module (srfi srfi-1)
50 #:use-module (srfi srfi-26)
51 #:use-module (srfi srfi-64)
52 #:use-module (srfi srfi-71)
53 #:use-module (ice-9 threads)
54 #:use-module (ice-9 format)
55 #:use-module (ice-9 match)
56 #:use-module (ice-9 rdelim))
59 (open-connection-for-tests))
61 (define (zstd-supported?)
62 (resolve-module '(zstd) #t #f #:ensure #f))
64 (define %reference (add-text-to-store %store "ref" "foo"))
66 (define %item (add-text-to-store %store "item" "bar" (list %reference)))
68 (define (http-get-body uri)
69 (call-with-values (lambda () (http-get uri))
70 (lambda (response body) body)))
72 (define (http-get-port uri)
73 (let ((socket (open-socket-for-uri uri)))
74 ;; Make sure to use an unbuffered port so that we can then peek at the
75 ;; underlying file descriptor via 'call-with-gzip-input-port'.
76 (setvbuf socket 'none)
79 (http-get uri #:port socket #:streaming? #t))
80 (lambda (response port)
81 ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
82 ;; (PORT might be a custom binary input port).
85 (define (publish-uri route)
86 (string-append "http://localhost:6789" route))
88 (define-syntax-rule (with-separate-output-ports exp ...)
89 ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
90 ;; error ports to make sure the two threads don't end up stepping on each
92 (with-output-to-port (duplicate-port (current-output-port) "w")
94 (with-error-to-port (duplicate-port (current-error-port) "w")
98 ;; Run a local publishing server in a separate thread.
99 (with-separate-output-ports
100 (call-with-new-thread
102 (guix-publish "--port=6789" "-C0")))) ;attempt to avoid port collision
104 (define (wait-until-ready port)
105 ;; Wait until the server is accepting connections.
106 (let ((conn (socket PF_INET SOCK_STREAM 0)))
108 (unless (false-if-exception
109 (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
112 (define (wait-for-file file)
113 ;; Wait until FILE shows up.
115 (cond ((file-exists? file)
118 (error "file didn't show up" file))
120 (pk 'wait-for-file file)
124 (define %gzip-magic-bytes
125 ;; Magic bytes of gzip file.
128 ;; Wait until the two servers are ready.
129 (wait-until-ready 6789)
131 ;; Initialize the public/private key SRFI-39 parameters.
132 (%public-key (read-file-sexp %public-key-file))
133 (%private-key (read-file-sexp %private-key-file))
136 (test-begin "publish")
138 (test-equal "/nix-cache-info"
139 (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
141 (http-get-body (publish-uri "/nix-cache-info")))
143 (test-equal "/*.narinfo"
144 (let* ((info (query-path-info %store %item))
152 (bytevector->nix-base32-string
153 (path-info-hash info))
154 (path-info-nar-size info)
155 (basename (first (path-info-references info)))))
156 (signature (base64-encode
158 (canonical-sexp->string
159 (signed-string unsigned-info))))))
160 (format #f "~aSignature: 1;~a;~a
164 unsigned-info (gethostname) signature
166 (path-info-nar-size info)))
170 (string-append "/" (store-path-hash-part %item) ".narinfo")))))
172 (test-equal "/*.narinfo pipeline"
174 ;; Make sure clients can pipeline requests and correct responses, in the
175 ;; right order. See <https://issues.guix.gnu.org/54723>.
176 (let* ((uri (string->uri (publish-uri
178 (store-path-hash-part %item)
180 (_ expected (http-get uri #:streaming? #f #:decode-body? #f)))
181 (http-multiple-get (string->uri (publish-uri ""))
182 (lambda (request response port result)
183 (and (bytevector=? expected
184 (get-bytevector-n port
185 (response-content-length
187 (cons (response-code response) result)))
189 (make-list 500 (build-request uri))
192 (test-equal "/*.narinfo with properly encoded '+' sign"
193 ;; See <http://bugs.gnu.org/21888>.
194 (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
195 (info (query-path-info %store item))
203 (bytevector->nix-base32-string
204 (path-info-hash info))
205 (path-info-nar-size info)))
206 (signature (base64-encode
208 (canonical-sexp->string
209 (signed-string unsigned-info))))))
210 (format #f "~aSignature: 1;~a;~a
214 unsigned-info (gethostname) signature
215 (uri-encode (basename item))
216 (path-info-nar-size info)))
218 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
222 (string-append "/" (store-path-hash-part item) ".narinfo"))))))
226 (call-with-temporary-output-file
228 (let ((nar (utf8->string
231 (string-append "/nar/" (basename %item)))))))
232 (call-with-input-string nar (cut restore-file <> temp)))
233 (call-with-input-file temp read-string))))
235 (test-equal "/nar/gzip/*"
237 (call-with-temporary-output-file
239 (let ((nar (http-get-port
241 (string-append "/nar/gzip/" (basename %item))))))
242 (call-with-gzip-input-port nar
243 (cut restore-file <> temp)))
244 (call-with-input-file temp read-string))))
246 (test-equal "/nar/gzip/* is really gzip"
248 ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
249 ;; uncompressed gzip, the test above doesn't check whether it's actually
250 ;; gzip. This is what this test does. See <https://bugs.gnu.org/30184>.
251 (let ((nar (http-get-port
253 (string-append "/nar/gzip/" (basename %item))))))
254 (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
256 (test-equal "/nar/lzip/*"
258 (call-with-temporary-output-file
260 (let ((nar (http-get-port
262 (string-append "/nar/lzip/" (basename %item))))))
263 (call-with-lzip-input-port nar
264 (cut restore-file <> temp)))
265 (call-with-input-file temp read-string))))
267 (unless (zstd-supported?) (test-skip 1))
268 (test-equal "/nar/zstd/*"
270 (call-with-temporary-output-file
272 (let ((nar (http-get-port
274 (string-append "/nar/zstd/" (basename %item))))))
275 (call-with-zstd-input-port nar
276 (cut restore-file <> temp)))
277 (call-with-input-file temp read-string))))
279 (test-equal "/*.narinfo with compression"
280 `(("StorePath" . ,%item)
281 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
282 ("Compression" . "gzip"))
283 (let ((thread (with-separate-output-ports
284 (call-with-new-thread
286 (guix-publish "--port=6799" "-C5"))))))
287 (wait-until-ready 6799)
288 (let* ((url (string-append "http://localhost:6799/"
289 (store-path-hash-part %item) ".narinfo"))
290 (body (http-get-port url)))
291 (filter (lambda (item)
293 (("Compression" . _) #t)
294 (("StorePath" . _) #t)
297 (recutils->alist body)))))
299 (test-equal "/*.narinfo with lzip compression"
300 `(("StorePath" . ,%item)
301 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
302 ("Compression" . "lzip"))
303 (let ((thread (with-separate-output-ports
304 (call-with-new-thread
306 (guix-publish "--port=6790" "-Clzip"))))))
307 (wait-until-ready 6790)
308 (let* ((url (string-append "http://localhost:6790/"
309 (store-path-hash-part %item) ".narinfo"))
310 (body (http-get-port url)))
311 (filter (lambda (item)
313 (("Compression" . _) #t)
314 (("StorePath" . _) #t)
317 (recutils->alist body)))))
319 (test-equal "/*.narinfo for a compressed file"
320 '("none" "nar") ;compression-less nar
321 ;; Assume 'guix publish -C' is already running on port 6799.
322 (let* ((item (add-text-to-store %store "fake.tar.gz"
323 "This is a fake compressed file."))
324 (url (string-append "http://localhost:6799/"
325 (store-path-hash-part item) ".narinfo"))
326 (body (http-get-port url))
327 (info (recutils->alist body)))
328 (list (assoc-ref info "Compression")
329 (dirname (assoc-ref info "URL")))))
331 (test-equal "/*.narinfo with lzip + gzip"
332 `((("StorePath" . ,%item)
333 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
334 ("Compression" . "gzip")
335 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
336 ("Compression" . "lzip"))
339 (call-with-temporary-directory
341 (let ((thread (with-separate-output-ports
342 (call-with-new-thread
344 (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
345 (wait-until-ready 6793)
346 (let* ((base "http://localhost:6793/")
347 (part (store-path-hash-part %item))
348 (url (string-append base part ".narinfo"))
349 (body (http-get-port url)))
350 (list (filter (match-lambda
351 (("StorePath" . _) #t)
353 (("Compression" . _) #t)
355 (recutils->alist body))
357 (http-get (string-append base "nar/gzip/"
360 (http-get (string-append base "nar/lzip/"
361 (basename %item))))))))))
363 (test-equal "custom nar path"
364 ;; Serve nars at /foo/bar/chbouib instead of /nar.
365 (list `(("StorePath" . ,%item)
366 ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
367 ("Compression" . "none"))
370 (let ((thread (with-separate-output-ports
371 (call-with-new-thread
373 (guix-publish "--port=6798" "-C0"
374 "--nar-path=///foo/bar//chbouib/"))))))
375 (wait-until-ready 6798)
376 (let* ((base "http://localhost:6798/")
377 (part (store-path-hash-part %item))
378 (url (string-append base part ".narinfo"))
379 (nar-url (string-append base "foo/bar/chbouib/"
381 (body (http-get-port url)))
382 (list (filter (lambda (item)
384 (("Compression" . _) #t)
385 (("StorePath" . _) #t)
388 (recutils->alist body))
389 (response-code (http-get nar-url))
391 (http-get (string-append base "nar/" (basename %item))))))))
393 (test-equal "/nar/ with properly encoded '+' sign"
395 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
396 (call-with-temporary-output-file
398 (let ((nar (utf8->string
401 (string-append "/nar/" (uri-encode (basename item))))))))
402 (call-with-input-string nar (cut restore-file <> temp)))
403 (call-with-input-file temp read-string)))))
405 (test-equal "/nar/invalid"
408 (call-with-output-file (string-append (%store-prefix) "/invalid")
410 (display "This file is not a valid store item." port)))
411 (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))
413 (test-equal "/file/NAME/sha256/HASH"
415 (let* ((data "Hello, Guix world!")
416 (hash (call-with-input-string data port-sha256))
417 (drv (run-with-store %store
418 (gexp->derivation "the-file.txt"
419 #~(call-with-output-file #$output
421 (display #$data port)))
424 (out (build-derivations %store (list drv))))
428 (string-append "/file/the-file.txt/sha256/"
429 (bytevector->nix-base32-string hash)))))))
431 (test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
433 (let ((uri (publish-uri
434 "/file/the-file.txt/sha256/not-a-nix-base32-string")))
435 (response-code (http-get uri))))
437 (test-equal "/file/NAME/sha256/INVALID-HASH"
439 (let ((uri (publish-uri
440 (string-append "/file/the-file.txt/sha256/"
441 (bytevector->nix-base32-string
442 (call-with-input-string "" port-sha256))))))
443 (response-code (http-get uri))))
445 (test-equal "with cache"
447 `(("StorePath" . ,%item)
448 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
449 ("Compression" . "gzip"))
454 (call-with-temporary-directory
456 (let ((thread (with-separate-output-ports
457 (call-with-new-thread
459 (guix-publish "--port=6797" "-C2"
460 (string-append "--cache=" cache)
461 "--cache-bypass-threshold=0"))))))
462 (wait-until-ready 6797)
463 (let* ((base "http://localhost:6797/")
464 (part (store-path-hash-part %item))
465 (url (string-append base part ".narinfo"))
466 (nar-url (string-append base "nar/gzip/" (basename %item)))
467 (cached (string-append cache "/gzip/" (basename %item)
469 (nar (string-append cache "/gzip/"
470 (basename %item) ".nar"))
471 (response (http-get url)))
472 (and (= 404 (response-code response))
474 ;; We should get an explicitly short TTL for 404 in this case
475 ;; because it's going to become 200 shortly.
476 (match (assq-ref (response-headers response) 'cache-control)
480 (wait-for-file cached)
482 ;; Both the narinfo and nar should be world-readable.
483 (= #o444 (logand #o444 (stat:perms (lstat cached))))
484 (= #o444 (logand #o444 (stat:perms (lstat nar))))
486 (let* ((body (http-get-port url))
487 (compressed (http-get nar-url))
488 (uncompressed (http-get (string-append base "nar/"
490 (narinfo (recutils->alist body)))
491 (list (file-exists? nar)
492 (filter (lambda (item)
494 (("Compression" . _) #t)
495 (("StorePath" . _) #t)
499 (response-code compressed)
500 (= (response-content-length compressed)
501 (stat:size (stat nar)))
503 (assoc-ref narinfo "FileSize"))
504 (stat:size (stat nar)))
505 (response-code uncompressed)))))))))
507 (test-equal "with cache, lzip + gzip"
509 (call-with-temporary-directory
511 (let ((thread (with-separate-output-ports
512 (call-with-new-thread
514 (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
515 (string-append "--cache=" cache)
516 "--cache-bypass-threshold=0"))))))
517 (wait-until-ready 6794)
518 (let* ((base "http://localhost:6794/")
519 (part (store-path-hash-part %item))
520 (url (string-append base part ".narinfo"))
521 (nar-url (cute string-append "nar/" <> "/"
523 (cached (cute string-append cache "/" <> "/"
524 (basename %item) ".narinfo"))
525 (nar (cute string-append cache "/" <> "/"
526 (basename %item) ".nar"))
527 (response (http-get url)))
528 (wait-for-file (cached "gzip"))
529 (let* ((body (http-get-port url))
530 (narinfo (recutils->alist body))
531 (uncompressed (string-append base "nar/"
533 (and (file-exists? (nar "gzip"))
534 (file-exists? (nar "lzip"))
535 (match (pk 'narinfo/gzip+lzip narinfo)
536 ((("StorePath" . path)
540 ("Compression" . "gzip")
541 ("FileSize" . (= string->number gzip-size))
543 ("Compression" . "lzip")
544 ("FileSize" . (= string->number lzip-size)))
545 (and (string=? gzip-url (nar-url "gzip"))
546 (string=? lzip-url (nar-url "lzip"))
548 (stat:size (stat (nar "gzip"))))
550 (stat:size (stat (nar "lzip")))))))
552 (http-get (string-append base (nar-url "gzip"))))
554 (http-get (string-append base (nar-url "lzip"))))
556 (http-get uncompressed))))))))))
558 (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
560 (test-equal "with cache, uncompressed"
562 (* 42 3600) ;TTL on narinfo
563 `(("StorePath" . ,item)
564 ("URL" . ,(string-append "nar/" (basename item)))
565 ("Compression" . "none"))
567 (* 42 3600) ;TTL on nar/…
569 (query-path-info %store item)) ;FileSize
571 (call-with-temporary-directory
573 (let ((thread (with-separate-output-ports
574 (call-with-new-thread
576 (guix-publish "--port=6796" "-C2" "--ttl=42h"
577 (string-append "--cache=" cache)
578 "--cache-bypass-threshold=0"))))))
579 (wait-until-ready 6796)
580 (let* ((base "http://localhost:6796/")
581 (part (store-path-hash-part item))
582 (url (string-append base part ".narinfo"))
583 (cached (string-append cache "/none/"
584 (basename item) ".narinfo"))
585 (nar (string-append cache "/none/"
586 (basename item) ".nar"))
587 (response (http-get url)))
588 (and (= 404 (response-code response))
590 (wait-for-file cached)
591 (let* ((response (http-get url))
592 (body (http-get-port url))
593 (compressed (http-get (string-append base "nar/gzip/"
595 (uncompressed (http-get (string-append base "nar/"
597 (narinfo (recutils->alist body)))
598 (list (file-exists? nar)
599 (match (assq-ref (response-headers response)
601 ((('max-age . ttl)) ttl)
604 (filter (lambda (item)
606 (("Compression" . _) #t)
607 (("StorePath" . _) #t)
611 (response-code uncompressed)
612 (match (assq-ref (response-headers uncompressed)
614 ((('max-age . ttl)) ttl)
618 (assoc-ref narinfo "FileSize"))
619 (response-code compressed))))))))))
621 (test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897>
623 (call-with-temporary-directory
625 (let ((thread (with-separate-output-ports
626 (call-with-new-thread
628 (guix-publish "--port=6795"
629 (string-append "--cache=" cache)))))))
630 (wait-until-ready 6795)
632 ;; Make sure that, even if ITEM disappears, we're still able to fetch
634 (let* ((base "http://localhost:6795/")
635 (item (add-text-to-store %store "random" (random-text)))
636 (part (store-path-hash-part item))
637 (url (string-append base part ".narinfo"))
638 (cached (string-append cache "/gzip/"
641 (response (http-get url)))
642 (and (= 200 (response-code response)) ;we're below the threshold
643 (wait-for-file cached)
645 (delete-paths %store (list item))
646 (response-code (pk 'response (http-get url))))))))))
648 (test-equal "with cache, cache bypass"
650 (call-with-temporary-directory
652 (let ((thread (with-separate-output-ports
653 (call-with-new-thread
655 (guix-publish "--port=6788" "-C" "gzip"
656 (string-append "--cache=" cache)))))))
657 (wait-until-ready 6788)
659 (let* ((base "http://localhost:6788/")
660 (item (add-text-to-store %store "random" (random-text)))
661 (part (store-path-hash-part item))
662 (narinfo (string-append base part ".narinfo"))
663 (nar (string-append base "nar/gzip/" (basename item)))
664 (cached (string-append cache "/gzip/" (basename item)
666 ;; We're below the default cache bypass threshold, so NAR and NARINFO
667 ;; should immediately return 200. The NARINFO request should trigger
668 ;; caching, and the next request to NAR should return 200 as well.
669 (and (let ((response (pk 'r1 (http-get nar))))
670 (and (= 200 (response-code response))
671 (not (response-content-length response)))) ;not known
672 (= 200 (response-code (http-get narinfo)))
674 (wait-for-file cached)
675 (let ((response (pk 'r2 (http-get nar))))
676 (and (> (response-content-length response)
677 (stat:size (stat item)))
678 (response-code response))))))))))
680 (test-equal "with cache, cache bypass, unmapped hash part"
683 ;; This test reproduces the bug described in <https://bugs.gnu.org/44442>:
684 ;; the daemon connection would be closed as a side effect of a nar request
685 ;; for a non-existing file name.
686 (call-with-temporary-directory
688 (let ((thread (with-separate-output-ports
689 (call-with-new-thread
691 (guix-publish "--port=6787" "-C" "gzip"
692 (string-append "--cache=" cache)))))))
693 (wait-until-ready 6787)
695 (let* ((base "http://localhost:6787/")
696 (item (add-text-to-store %store "random" (random-text)))
697 (part (store-path-hash-part item))
698 (narinfo (string-append base part ".narinfo"))
699 (nar (string-append base "nar/gzip/" (basename item)))
700 (cached (string-append cache "/gzip/" (basename item)
702 ;; The first response used to be 500 and to terminate the daemon
703 ;; connection as a side effect.
704 (and (= (response-code
705 (http-get (string-append base "nar/gzip/"
709 (= 200 (response-code (http-get nar)))
710 (= 200 (response-code (http-get narinfo)))
712 (wait-for-file cached)
713 (response-code (http-get nar)))))))))
715 (test-equal "/log/NAME"
716 `(200 #t text/plain (gzip))
717 (let ((drv (run-with-store %store
718 (gexp->derivation "with-log"
719 #~(call-with-output-file #$output
721 (display "Hello, build log!"
722 (current-error-port))
723 (display #$(random-text) port)))))))
724 (build-derivations %store (list drv))
725 (let* ((response (http-get
726 (publish-uri (string-append "/log/"
727 (basename (derivation->output-path drv))))
729 (base (basename (derivation-file-name drv)))
730 (log (string-append (dirname %state-directory)
731 "/log/guix/drvs/" (string-take base 2)
732 "/" (string-drop base 2) ".gz")))
733 (list (response-code response)
734 (= (response-content-length response) (stat:size (stat log)))
735 (first (response-content-type response))
736 (response-content-encoding response)))))
738 (test-equal "negative TTL"
741 (call-with-temporary-directory
743 (let ((thread (with-separate-output-ports
744 (call-with-new-thread
746 (guix-publish "--port=6786" "-C0"
747 "--negative-ttl=42s"))))))
748 (wait-until-ready 6786)
750 (let* ((base "http://localhost:6786/")
751 (url (string-append base (make-string 32 #\z)
753 (response (http-get url)))
754 (list (response-code response)
755 (match (assq-ref (response-headers response) 'cache-control)
756 ((('max-age . ttl)) ttl)
759 (test-equal "no negative TTL"
761 (let* ((uri (publish-uri
762 (string-append "/" (make-string 32 #\z)
764 (response (http-get uri)))
765 (list (response-code response)
766 (assq-ref (response-headers response) 'cache-control))))
768 (test-equal "/log/NAME not found"
770 (let ((uri (publish-uri "/log/does-not-exist")))
771 (response-code (http-get uri))))
773 (test-equal "/signing-key.pub"
775 (response-code (http-get (publish-uri "/signing-key.pub"))))
777 (test-equal "non-GET query"
779 (let ((path (string-append "/" (store-path-hash-part %item)
782 (list (http-get (publish-uri path))
783 (http-post (publish-uri path))))))