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 #:autoload (zstd) (call-with-zstd-input-port)
42 #:use-module (web uri)
43 #:use-module (web client)
44 #:use-module (web response)
45 #:use-module (rnrs bytevectors)
46 #:use-module (ice-9 binary-ports)
47 #:use-module (srfi srfi-1)
48 #:use-module (srfi srfi-26)
49 #:use-module (srfi srfi-64)
50 #:use-module (ice-9 threads)
51 #:use-module (ice-9 format)
52 #:use-module (ice-9 match)
53 #:use-module (ice-9 rdelim))
56 (open-connection-for-tests))
58 (define (zstd-supported?)
59 (resolve-module '(zstd) #t #f #:ensure #f))
61 (define %reference (add-text-to-store %store "ref" "foo"))
63 (define %item (add-text-to-store %store "item" "bar" (list %reference)))
65 (define (http-get-body uri)
66 (call-with-values (lambda () (http-get uri))
67 (lambda (response body) body)))
69 (define (http-get-port uri)
70 (let ((socket (open-socket-for-uri uri)))
71 ;; Make sure to use an unbuffered port so that we can then peek at the
72 ;; underlying file descriptor via 'call-with-gzip-input-port'.
73 (setvbuf socket 'none)
76 (http-get uri #:port socket #:streaming? #t))
77 (lambda (response port)
78 ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
79 ;; (PORT might be a custom binary input port).
82 (define (publish-uri route)
83 (string-append "http://localhost:6789" route))
85 (define-syntax-rule (with-separate-output-ports exp ...)
86 ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
87 ;; error ports to make sure the two threads don't end up stepping on each
89 (with-output-to-port (duplicate-port (current-output-port) "w")
91 (with-error-to-port (duplicate-port (current-error-port) "w")
95 ;; Run a local publishing server in a separate thread.
96 (with-separate-output-ports
99 (guix-publish "--port=6789" "-C0")))) ;attempt to avoid port collision
101 (define (wait-until-ready port)
102 ;; Wait until the server is accepting connections.
103 (let ((conn (socket PF_INET SOCK_STREAM 0)))
105 (unless (false-if-exception
106 (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
109 (define (wait-for-file file)
110 ;; Wait until FILE shows up.
112 (cond ((file-exists? file)
115 (error "file didn't show up" file))
117 (pk 'wait-for-file file)
121 (define %gzip-magic-bytes
122 ;; Magic bytes of gzip file.
125 ;; Wait until the two servers are ready.
126 (wait-until-ready 6789)
128 ;; Initialize the public/private key SRFI-39 parameters.
129 (%public-key (read-file-sexp %public-key-file))
130 (%private-key (read-file-sexp %private-key-file))
133 (test-begin "publish")
135 (test-equal "/nix-cache-info"
136 (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
138 (http-get-body (publish-uri "/nix-cache-info")))
140 (test-equal "/*.narinfo"
141 (let* ((info (query-path-info %store %item))
153 (path-info-nar-size info)
154 (bytevector->nix-base32-string
155 (path-info-hash info))
156 (path-info-nar-size info)
157 (basename (first (path-info-references info)))))
158 (signature (base64-encode
160 (canonical-sexp->string
161 (signed-string unsigned-info))))))
162 (format #f "~aSignature: 1;~a;~a~%"
163 unsigned-info (gethostname) signature))
167 (string-append "/" (store-path-hash-part %item) ".narinfo")))))
169 (test-equal "/*.narinfo with properly encoded '+' sign"
170 ;; See <http://bugs.gnu.org/21888>.
171 (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
172 (info (query-path-info %store item))
183 (uri-encode (basename item))
184 (path-info-nar-size info)
185 (bytevector->nix-base32-string
186 (path-info-hash info))
187 (path-info-nar-size info)))
188 (signature (base64-encode
190 (canonical-sexp->string
191 (signed-string unsigned-info))))))
192 (format #f "~aSignature: 1;~a;~a~%"
193 unsigned-info (gethostname) signature))
195 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
199 (string-append "/" (store-path-hash-part item) ".narinfo"))))))
203 (call-with-temporary-output-file
205 (let ((nar (utf8->string
208 (string-append "/nar/" (basename %item)))))))
209 (call-with-input-string nar (cut restore-file <> temp)))
210 (call-with-input-file temp read-string))))
212 (test-equal "/nar/gzip/*"
214 (call-with-temporary-output-file
216 (let ((nar (http-get-port
218 (string-append "/nar/gzip/" (basename %item))))))
219 (call-with-gzip-input-port nar
220 (cut restore-file <> temp)))
221 (call-with-input-file temp read-string))))
223 (test-equal "/nar/gzip/* is really gzip"
225 ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
226 ;; uncompressed gzip, the test above doesn't check whether it's actually
227 ;; gzip. This is what this test does. See <https://bugs.gnu.org/30184>.
228 (let ((nar (http-get-port
230 (string-append "/nar/gzip/" (basename %item))))))
231 (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
233 (test-equal "/nar/lzip/*"
235 (call-with-temporary-output-file
237 (let ((nar (http-get-port
239 (string-append "/nar/lzip/" (basename %item))))))
240 (call-with-lzip-input-port nar
241 (cut restore-file <> temp)))
242 (call-with-input-file temp read-string))))
244 (unless (zstd-supported?) (test-skip 1))
245 (test-equal "/nar/zstd/*"
247 (call-with-temporary-output-file
249 (let ((nar (http-get-port
251 (string-append "/nar/zstd/" (basename %item))))))
252 (call-with-zstd-input-port nar
253 (cut restore-file <> temp)))
254 (call-with-input-file temp read-string))))
256 (test-equal "/*.narinfo with compression"
257 `(("StorePath" . ,%item)
258 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
259 ("Compression" . "gzip"))
260 (let ((thread (with-separate-output-ports
261 (call-with-new-thread
263 (guix-publish "--port=6799" "-C5"))))))
264 (wait-until-ready 6799)
265 (let* ((url (string-append "http://localhost:6799/"
266 (store-path-hash-part %item) ".narinfo"))
267 (body (http-get-port url)))
268 (filter (lambda (item)
270 (("Compression" . _) #t)
271 (("StorePath" . _) #t)
274 (recutils->alist body)))))
276 (test-equal "/*.narinfo with lzip compression"
277 `(("StorePath" . ,%item)
278 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
279 ("Compression" . "lzip"))
280 (let ((thread (with-separate-output-ports
281 (call-with-new-thread
283 (guix-publish "--port=6790" "-Clzip"))))))
284 (wait-until-ready 6790)
285 (let* ((url (string-append "http://localhost:6790/"
286 (store-path-hash-part %item) ".narinfo"))
287 (body (http-get-port url)))
288 (filter (lambda (item)
290 (("Compression" . _) #t)
291 (("StorePath" . _) #t)
294 (recutils->alist body)))))
296 (test-equal "/*.narinfo for a compressed file"
297 '("none" "nar") ;compression-less nar
298 ;; Assume 'guix publish -C' is already running on port 6799.
299 (let* ((item (add-text-to-store %store "fake.tar.gz"
300 "This is a fake compressed file."))
301 (url (string-append "http://localhost:6799/"
302 (store-path-hash-part item) ".narinfo"))
303 (body (http-get-port url))
304 (info (recutils->alist body)))
305 (list (assoc-ref info "Compression")
306 (dirname (assoc-ref info "URL")))))
308 (test-equal "/*.narinfo with lzip + gzip"
309 `((("StorePath" . ,%item)
310 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
311 ("Compression" . "gzip")
312 ("URL" . ,(string-append "nar/lzip/" (basename %item)))
313 ("Compression" . "lzip"))
316 (call-with-temporary-directory
318 (let ((thread (with-separate-output-ports
319 (call-with-new-thread
321 (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
322 (wait-until-ready 6793)
323 (let* ((base "http://localhost:6793/")
324 (part (store-path-hash-part %item))
325 (url (string-append base part ".narinfo"))
326 (body (http-get-port url)))
327 (list (take (recutils->alist body) 5)
329 (http-get (string-append base "nar/gzip/"
332 (http-get (string-append base "nar/lzip/"
333 (basename %item))))))))))
335 (test-equal "custom nar path"
336 ;; Serve nars at /foo/bar/chbouib instead of /nar.
337 (list `(("StorePath" . ,%item)
338 ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
339 ("Compression" . "none"))
342 (let ((thread (with-separate-output-ports
343 (call-with-new-thread
345 (guix-publish "--port=6798" "-C0"
346 "--nar-path=///foo/bar//chbouib/"))))))
347 (wait-until-ready 6798)
348 (let* ((base "http://localhost:6798/")
349 (part (store-path-hash-part %item))
350 (url (string-append base part ".narinfo"))
351 (nar-url (string-append base "foo/bar/chbouib/"
353 (body (http-get-port url)))
354 (list (filter (lambda (item)
356 (("Compression" . _) #t)
357 (("StorePath" . _) #t)
360 (recutils->alist body))
361 (response-code (http-get nar-url))
363 (http-get (string-append base "nar/" (basename %item))))))))
365 (test-equal "/nar/ with properly encoded '+' sign"
367 (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
368 (call-with-temporary-output-file
370 (let ((nar (utf8->string
373 (string-append "/nar/" (uri-encode (basename item))))))))
374 (call-with-input-string nar (cut restore-file <> temp)))
375 (call-with-input-file temp read-string)))))
377 (test-equal "/nar/invalid"
380 (call-with-output-file (string-append (%store-prefix) "/invalid")
382 (display "This file is not a valid store item." port)))
383 (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))
385 (test-equal "/file/NAME/sha256/HASH"
387 (let* ((data "Hello, Guix world!")
388 (hash (call-with-input-string data port-sha256))
389 (drv (run-with-store %store
390 (gexp->derivation "the-file.txt"
391 #~(call-with-output-file #$output
393 (display #$data port)))
396 (out (build-derivations %store (list drv))))
400 (string-append "/file/the-file.txt/sha256/"
401 (bytevector->nix-base32-string hash)))))))
403 (test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
405 (let ((uri (publish-uri
406 "/file/the-file.txt/sha256/not-a-nix-base32-string")))
407 (response-code (http-get uri))))
409 (test-equal "/file/NAME/sha256/INVALID-HASH"
411 (let ((uri (publish-uri
412 (string-append "/file/the-file.txt/sha256/"
413 (bytevector->nix-base32-string
414 (call-with-input-string "" port-sha256))))))
415 (response-code (http-get uri))))
417 (test-equal "with cache"
419 `(("StorePath" . ,%item)
420 ("URL" . ,(string-append "nar/gzip/" (basename %item)))
421 ("Compression" . "gzip"))
426 (call-with-temporary-directory
428 (let ((thread (with-separate-output-ports
429 (call-with-new-thread
431 (guix-publish "--port=6797" "-C2"
432 (string-append "--cache=" cache)
433 "--cache-bypass-threshold=0"))))))
434 (wait-until-ready 6797)
435 (let* ((base "http://localhost:6797/")
436 (part (store-path-hash-part %item))
437 (url (string-append base part ".narinfo"))
438 (nar-url (string-append base "nar/gzip/" (basename %item)))
439 (cached (string-append cache "/gzip/" (basename %item)
441 (nar (string-append cache "/gzip/"
442 (basename %item) ".nar"))
443 (response (http-get url)))
444 (and (= 404 (response-code response))
446 ;; We should get an explicitly short TTL for 404 in this case
447 ;; because it's going to become 200 shortly.
448 (match (assq-ref (response-headers response) 'cache-control)
452 (wait-for-file cached)
454 ;; Both the narinfo and nar should be world-readable.
455 (= #o444 (logand #o444 (stat:perms (lstat cached))))
456 (= #o444 (logand #o444 (stat:perms (lstat nar))))
458 (let* ((body (http-get-port url))
459 (compressed (http-get nar-url))
460 (uncompressed (http-get (string-append base "nar/"
462 (narinfo (recutils->alist body)))
463 (list (file-exists? nar)
464 (filter (lambda (item)
466 (("Compression" . _) #t)
467 (("StorePath" . _) #t)
471 (response-code compressed)
472 (= (response-content-length compressed)
473 (stat:size (stat nar)))
475 (assoc-ref narinfo "FileSize"))
476 (stat:size (stat nar)))
477 (response-code uncompressed)))))))))
479 (test-equal "with cache, lzip + gzip"
481 (call-with-temporary-directory
483 (let ((thread (with-separate-output-ports
484 (call-with-new-thread
486 (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
487 (string-append "--cache=" cache)
488 "--cache-bypass-threshold=0"))))))
489 (wait-until-ready 6794)
490 (let* ((base "http://localhost:6794/")
491 (part (store-path-hash-part %item))
492 (url (string-append base part ".narinfo"))
493 (nar-url (cute string-append "nar/" <> "/"
495 (cached (cute string-append cache "/" <> "/"
496 (basename %item) ".narinfo"))
497 (nar (cute string-append cache "/" <> "/"
498 (basename %item) ".nar"))
499 (response (http-get url)))
500 (wait-for-file (cached "gzip"))
501 (let* ((body (http-get-port url))
502 (narinfo (recutils->alist body))
503 (uncompressed (string-append base "nar/"
505 (and (file-exists? (nar "gzip"))
506 (file-exists? (nar "lzip"))
507 (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
508 `(("StorePath" . ,%item)
509 ("URL" . ,(nar-url "gzip"))
510 ("Compression" . "gzip")
511 ("FileSize" . ,(number->string
512 (stat:size (stat (nar "gzip")))))
513 ("URL" . ,(nar-url "lzip"))
514 ("Compression" . "lzip")
515 ("FileSize" . ,(number->string
516 (stat:size (stat (nar "lzip")))))))
518 (http-get (string-append base (nar-url "gzip"))))
520 (http-get (string-append base (nar-url "lzip"))))
522 (http-get uncompressed))))))))))
524 (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
526 (test-equal "with cache, uncompressed"
528 (* 42 3600) ;TTL on narinfo
529 `(("StorePath" . ,item)
530 ("URL" . ,(string-append "nar/" (basename item)))
531 ("Compression" . "none"))
533 (* 42 3600) ;TTL on nar/…
535 (query-path-info %store item)) ;FileSize
537 (call-with-temporary-directory
539 (let ((thread (with-separate-output-ports
540 (call-with-new-thread
542 (guix-publish "--port=6796" "-C2" "--ttl=42h"
543 (string-append "--cache=" cache)
544 "--cache-bypass-threshold=0"))))))
545 (wait-until-ready 6796)
546 (let* ((base "http://localhost:6796/")
547 (part (store-path-hash-part item))
548 (url (string-append base part ".narinfo"))
549 (cached (string-append cache "/none/"
550 (basename item) ".narinfo"))
551 (nar (string-append cache "/none/"
552 (basename item) ".nar"))
553 (response (http-get url)))
554 (and (= 404 (response-code response))
556 (wait-for-file cached)
557 (let* ((response (http-get url))
558 (body (http-get-port url))
559 (compressed (http-get (string-append base "nar/gzip/"
561 (uncompressed (http-get (string-append base "nar/"
563 (narinfo (recutils->alist body)))
564 (list (file-exists? nar)
565 (match (assq-ref (response-headers response)
567 ((('max-age . ttl)) ttl)
570 (filter (lambda (item)
572 (("Compression" . _) #t)
573 (("StorePath" . _) #t)
577 (response-code uncompressed)
578 (match (assq-ref (response-headers uncompressed)
580 ((('max-age . ttl)) ttl)
584 (assoc-ref narinfo "FileSize"))
585 (response-code compressed))))))))))
587 (test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897>
589 (call-with-temporary-directory
591 (let ((thread (with-separate-output-ports
592 (call-with-new-thread
594 (guix-publish "--port=6795"
595 (string-append "--cache=" cache)))))))
596 (wait-until-ready 6795)
598 ;; Make sure that, even if ITEM disappears, we're still able to fetch
600 (let* ((base "http://localhost:6795/")
601 (item (add-text-to-store %store "random" (random-text)))
602 (part (store-path-hash-part item))
603 (url (string-append base part ".narinfo"))
604 (cached (string-append cache "/gzip/"
607 (response (http-get url)))
608 (and (= 200 (response-code response)) ;we're below the threshold
609 (wait-for-file cached)
611 (delete-paths %store (list item))
612 (response-code (pk 'response (http-get url))))))))))
614 (test-equal "with cache, cache bypass"
616 (call-with-temporary-directory
618 (let ((thread (with-separate-output-ports
619 (call-with-new-thread
621 (guix-publish "--port=6788" "-C" "gzip"
622 (string-append "--cache=" cache)))))))
623 (wait-until-ready 6788)
625 (let* ((base "http://localhost:6788/")
626 (item (add-text-to-store %store "random" (random-text)))
627 (part (store-path-hash-part item))
628 (narinfo (string-append base part ".narinfo"))
629 (nar (string-append base "nar/gzip/" (basename item)))
630 (cached (string-append cache "/gzip/" (basename item)
632 ;; We're below the default cache bypass threshold, so NAR and NARINFO
633 ;; should immediately return 200. The NARINFO request should trigger
634 ;; caching, and the next request to NAR should return 200 as well.
635 (and (let ((response (pk 'r1 (http-get nar))))
636 (and (= 200 (response-code response))
637 (not (response-content-length response)))) ;not known
638 (= 200 (response-code (http-get narinfo)))
640 (wait-for-file cached)
641 (let ((response (pk 'r2 (http-get nar))))
642 (and (> (response-content-length response)
643 (stat:size (stat item)))
644 (response-code response))))))))))
646 (test-equal "with cache, cache bypass, unmapped hash part"
649 ;; This test reproduces the bug described in <https://bugs.gnu.org/44442>:
650 ;; the daemon connection would be closed as a side effect of a nar request
651 ;; for a non-existing file name.
652 (call-with-temporary-directory
654 (let ((thread (with-separate-output-ports
655 (call-with-new-thread
657 (guix-publish "--port=6787" "-C" "gzip"
658 (string-append "--cache=" cache)))))))
659 (wait-until-ready 6787)
661 (let* ((base "http://localhost:6787/")
662 (item (add-text-to-store %store "random" (random-text)))
663 (part (store-path-hash-part item))
664 (narinfo (string-append base part ".narinfo"))
665 (nar (string-append base "nar/gzip/" (basename item)))
666 (cached (string-append cache "/gzip/" (basename item)
668 ;; The first response used to be 500 and to terminate the daemon
669 ;; connection as a side effect.
670 (and (= (response-code
671 (http-get (string-append base "nar/gzip/"
675 (= 200 (response-code (http-get nar)))
676 (= 200 (response-code (http-get narinfo)))
678 (wait-for-file cached)
679 (response-code (http-get nar)))))))))
681 (test-equal "/log/NAME"
682 `(200 #t application/x-bzip2)
683 (let ((drv (run-with-store %store
684 (gexp->derivation "with-log"
685 #~(call-with-output-file #$output
687 (display "Hello, build log!"
688 (current-error-port))
689 (display #$(random-text) port)))))))
690 (build-derivations %store (list drv))
691 (let* ((response (http-get
692 (publish-uri (string-append "/log/"
693 (basename (derivation->output-path drv))))
695 (base (basename (derivation-file-name drv)))
696 (log (string-append (dirname %state-directory)
697 "/log/guix/drvs/" (string-take base 2)
698 "/" (string-drop base 2) ".bz2")))
699 (list (response-code response)
700 (= (response-content-length response) (stat:size (stat log)))
701 (first (response-content-type response))))))
703 (test-equal "/log/NAME not found"
705 (let ((uri (publish-uri "/log/does-not-exist")))
706 (response-code (http-get uri))))
708 (test-equal "/signing-key.pub"
710 (response-code (http-get (publish-uri "/signing-key.pub"))))
712 (test-equal "non-GET query"
714 (let ((path (string-append "/" (store-path-hash-part %item)
717 (list (http-get (publish-uri path))
718 (http-post (publish-uri path))))))