[jackhill/guix/guix.git] / tests / publish.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;; Avoid interference.
(unsetenv "http_proxy")

(define-module (test-publish)
  #:use-module (guix scripts publish)
  #:use-module (guix tests)
  #:use-module (guix config)
  #:use-module (guix utils)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module ((guix records) #:select (recutils->alist))
  #:use-module ((guix serialization) #:select (restore-file))
  #:use-module (gcrypt pk-crypto)
  #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
  #:use-module (guix zlib)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim))

(define %store
  (open-connection-for-tests))

(define %reference (add-text-to-store %store "ref" "foo"))

(define %item (add-text-to-store %store "item" "bar" (list %reference)))

(define (http-get-body uri)
  (call-with-values (lambda () (http-get uri))
    (lambda (response body) body)))

(define (http-get-port uri)
  (let ((socket (open-socket-for-uri uri)))
    ;; Make sure to use an unbuffered port so that we can then peek at the
    ;; underlying file descriptor via 'call-with-gzip-input-port'.
    (setvbuf socket 'none)
    (call-with-values
        (lambda ()
          (http-get uri #:port socket #:streaming? #t))
      (lambda (response port)
        ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
        ;; (PORT might be a custom binary input port).
        port))))

(define (publish-uri route)
  (string-append "http://localhost:6789" route))

(define-syntax-rule (with-separate-output-ports exp ...)
  ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
  ;; error ports to make sure the two threads don't end up stepping on each
  ;; other's toes.
  (with-output-to-port (duplicate-port (current-output-port) "w")
    (lambda ()
      (with-error-to-port (duplicate-port (current-error-port) "w")
        (lambda ()
          exp ...)))))

;; Run a local publishing server in a separate thread.
(with-separate-output-ports
 (call-with-new-thread
  (lambda ()
    (guix-publish "--port=6789" "-C0"))))     ;attempt to avoid port collision

(define (wait-until-ready port)
  ;; Wait until the server is accepting connections.
  (let ((conn (socket PF_INET SOCK_STREAM 0)))
    (let loop ()
      (unless (false-if-exception
               (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
        (loop)))))

(define (wait-for-file file)
  ;; Wait until FILE shows up.
  (let loop ((i 20))
    (cond ((file-exists? file)
           #t)
          ((zero? i)
           (error "file didn't show up" file))
          (else
           (pk 'wait-for-file file)
           (sleep 1)
           (loop (- i 1))))))

(define %gzip-magic-bytes
  ;; Magic bytes of gzip file.
  #vu8(#x1f #x8b))

;; Wait until the two servers are ready.
(wait-until-ready 6789)

;; Initialize the public/private key SRFI-39 parameters.
(%public-key (read-file-sexp %public-key-file))
(%private-key (read-file-sexp %private-key-file))

\f
(test-begin "publish")

(test-equal "/nix-cache-info"
  (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
          %store-directory)
  (http-get-body (publish-uri "/nix-cache-info")))

(test-equal "/*.narinfo"
  (let* ((info (query-path-info %store %item))
         (unsigned-info
          (format #f
                  "StorePath: ~a
URL: nar/~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
References: ~a
FileSize: ~a~%"
                  %item
                  (basename %item)
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)
                  (basename (first (path-info-references info)))
                  (path-info-nar-size info)))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       ((@@ (guix scripts publish) signed-string)
                        unsigned-info))))))
    (format #f "~aSignature: 1;~a;~a~%"
            unsigned-info (gethostname) signature))
  (utf8->string
   (http-get-body
    (publish-uri
     (string-append "/" (store-path-hash-part %item) ".narinfo")))))

(test-equal "/*.narinfo with properly encoded '+' sign"
  ;; See <http://bugs.gnu.org/21888>.
  (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
         (info (query-path-info %store item))
         (unsigned-info
          (format #f
                  "StorePath: ~a
URL: nar/~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
References: ~%\
FileSize: ~a~%"
                  item
                  (uri-encode (basename item))
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)
                  (path-info-nar-size info)))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       ((@@ (guix scripts publish) signed-string)
                        unsigned-info))))))
    (format #f "~aSignature: 1;~a;~a~%"
            unsigned-info (gethostname) signature))

  (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
    (utf8->string
     (http-get-body
      (publish-uri
       (string-append "/" (store-path-hash-part item) ".narinfo"))))))

(test-equal "/nar/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (utf8->string
                 (http-get-body
                  (publish-uri
                   (string-append "/nar/" (basename %item)))))))
       (call-with-input-string nar (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(unless (zlib-available?)
  (test-skip 1))
(test-equal "/nar/gzip/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (http-get-port
                 (publish-uri
                  (string-append "/nar/gzip/" (basename %item))))))
       (call-with-gzip-input-port nar
         (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(unless (zlib-available?)
  (test-skip 1))
(test-equal "/nar/gzip/* is really gzip"
  %gzip-magic-bytes
  ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
  ;; uncompressed gzip, the test above doesn't check whether it's actually
  ;; gzip.  This is what this test does.  See <https://bugs.gnu.org/30184>.
  (let ((nar (http-get-port
              (publish-uri
               (string-append "/nar/gzip/" (basename %item))))))
    (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))

(unless (zlib-available?)
  (test-skip 1))
(test-equal "/*.narinfo with compression"
  `(("StorePath" . ,%item)
    ("URL" . ,(string-append "nar/gzip/" (basename %item)))
    ("Compression" . "gzip"))
  (let ((thread (with-separate-output-ports
                 (call-with-new-thread
                  (lambda ()
                    (guix-publish "--port=6799" "-C5"))))))
    (wait-until-ready 6799)
    (let* ((url  (string-append "http://localhost:6799/"
                                (store-path-hash-part %item) ".narinfo"))
           (body (http-get-port url)))
      (filter (lambda (item)
                (match item
                  (("Compression" . _) #t)
                  (("StorePath" . _)  #t)
                  (("URL" . _) #t)
                  (_ #f)))
              (recutils->alist body)))))

(unless (zlib-available?)
  (test-skip 1))
(test-equal "/*.narinfo for a compressed file"
  '("none" "nar")          ;compression-less nar
  ;; Assume 'guix publish -C' is already running on port 6799.
  (let* ((item (add-text-to-store %store "fake.tar.gz"
                                  "This is a fake compressed file."))
         (url  (string-append "http://localhost:6799/"
                              (store-path-hash-part item) ".narinfo"))
         (body (http-get-port url))
         (info (recutils->alist body)))
    (list (assoc-ref info "Compression")
          (dirname (assoc-ref info "URL")))))

(test-equal "custom nar path"
  ;; Serve nars at /foo/bar/chbouib instead of /nar.
  (list `(("StorePath" . ,%item)
          ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
          ("Compression" . "none"))
        200
        404)
  (let ((thread (with-separate-output-ports
                 (call-with-new-thread
                  (lambda ()
                    (guix-publish "--port=6798" "-C0"
                                  "--nar-path=///foo/bar//chbouib/"))))))
    (wait-until-ready 6798)
    (let* ((base    "http://localhost:6798/")
           (part    (store-path-hash-part %item))
           (url     (string-append base part ".narinfo"))
           (nar-url (string-append base "foo/bar/chbouib/"
                                   (basename %item)))
           (body    (http-get-port url)))
      (list (filter (lambda (item)
                      (match item
                        (("Compression" . _) #t)
                        (("StorePath" . _)  #t)
                        (("URL" . _) #t)
                        (_ #f)))
                    (recutils->alist body))
            (response-code (http-get nar-url))
            (response-code
             (http-get (string-append base "nar/" (basename %item))))))))

(test-equal "/nar/ with properly encoded '+' sign"
  "Congrats!"
  (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
    (call-with-temporary-output-file
     (lambda (temp port)
       (let ((nar (utf8->string
                   (http-get-body
                    (publish-uri
                     (string-append "/nar/" (uri-encode (basename item))))))))
         (call-with-input-string nar (cut restore-file <> temp)))
       (call-with-input-file temp read-string)))))

(test-equal "/nar/invalid"
  404
  (begin
    (call-with-output-file (string-append (%store-prefix) "/invalid")
      (lambda (port)
        (display "This file is not a valid store item." port)))
    (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))

(test-equal "/file/NAME/sha256/HASH"
  "Hello, Guix world!"
  (let* ((data "Hello, Guix world!")
         (hash (call-with-input-string data port-sha256))
         (drv  (run-with-store %store
                 (gexp->derivation "the-file.txt"
                                   #~(call-with-output-file #$output
                                       (lambda (port)
                                         (display #$data port)))
                                   #:hash-algo 'sha256
                                   #:hash hash)))
         (out  (build-derivations %store (list drv))))
    (utf8->string
     (http-get-body
      (publish-uri
       (string-append "/file/the-file.txt/sha256/"
                      (bytevector->nix-base32-string hash)))))))

(test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
  404
  (let ((uri (publish-uri
              "/file/the-file.txt/sha256/not-a-nix-base32-string")))
    (response-code (http-get uri))))

(test-equal "/file/NAME/sha256/INVALID-HASH"
  404
  (let ((uri (publish-uri
              (string-append "/file/the-file.txt/sha256/"
                             (bytevector->nix-base32-string
                              (call-with-input-string "" port-sha256))))))
    (response-code (http-get uri))))

(unless (zlib-available?)
  (test-skip 1))
(test-equal "with cache"
  (list #t
        `(("StorePath" . ,%item)
          ("URL" . ,(string-append "nar/gzip/" (basename %item)))
          ("Compression" . "gzip"))
        200                                       ;nar/gzip/…
        #t                                        ;Content-Length
        #t                                        ;FileSize
        404)                                      ;nar/…
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6797" "-C2"
                                     (string-append "--cache=" cache)))))))
       (wait-until-ready 6797)
       (let* ((base     "http://localhost:6797/")
              (part     (store-path-hash-part %item))
              (url      (string-append base part ".narinfo"))
              (nar-url  (string-append base "nar/gzip/" (basename %item)))
              (cached   (string-append cache "/gzip/" (basename %item)
                                       ".narinfo"))
              (nar      (string-append cache "/gzip/"
                                       (basename %item) ".nar"))
              (response (http-get url)))
         (and (= 404 (response-code response))

              ;; We should get an explicitly short TTL for 404 in this case
              ;; because it's going to become 200 shortly.
              (match (assq-ref (response-headers response) 'cache-control)
                ((('max-age . ttl))
                 (< ttl 3600)))

              (wait-for-file cached)
              (let* ((body         (http-get-port url))
                     (compressed   (http-get nar-url))
                     (uncompressed (http-get (string-append base "nar/"
                                                            (basename %item))))
                     (narinfo      (recutils->alist body)))
                (list (file-exists? nar)
                      (filter (lambda (item)
                                (match item
                                  (("Compression" . _) #t)
                                  (("StorePath" . _)  #t)
                                  (("URL" . _) #t)
                                  (_ #f)))
                              narinfo)
                      (response-code compressed)
                      (= (response-content-length compressed)
                         (stat:size (stat nar)))
                      (= (string->number
                          (assoc-ref narinfo "FileSize"))
                         (stat:size (stat nar)))
                      (response-code uncompressed)))))))))

(unless (zlib-available?)
  (test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
                               (random-text))))
  (test-equal "with cache, uncompressed"
    (list #t
          (* 42 3600)                             ;TTL on narinfo
          `(("StorePath" . ,item)
            ("URL" . ,(string-append "nar/" (basename item)))
            ("Compression" . "none"))
          200                                     ;nar/…
          (* 42 3600)                             ;TTL on nar/…
          (path-info-nar-size
           (query-path-info %store item))         ;FileSize
          404)                                    ;nar/gzip/…
    (call-with-temporary-directory
     (lambda (cache)
       (let ((thread (with-separate-output-ports
                      (call-with-new-thread
                       (lambda ()
                         (guix-publish "--port=6796" "-C2" "--ttl=42h"
                                       (string-append "--cache=" cache)))))))
         (wait-until-ready 6796)
         (let* ((base     "http://localhost:6796/")
                (part     (store-path-hash-part item))
                (url      (string-append base part ".narinfo"))
                (cached   (string-append cache "/none/"
                                         (basename item) ".narinfo"))
                (nar      (string-append cache "/none/"
                                         (basename item) ".nar"))
                (response (http-get url)))
           (and (= 404 (response-code response))

                (wait-for-file cached)
                (let* ((response     (http-get url))
                       (body         (http-get-port url))
                       (compressed   (http-get (string-append base "nar/gzip/"
                                                              (basename item))))
                       (uncompressed (http-get (string-append base "nar/"
                                                              (basename item))))
                       (narinfo      (recutils->alist body)))
                  (list (file-exists? nar)
                        (match (assq-ref (response-headers response)
                                         'cache-control)
                          ((('max-age . ttl)) ttl)
                          (_ #f))

                        (filter (lambda (item)
                                  (match item
                                    (("Compression" . _) #t)
                                    (("StorePath" . _)  #t)
                                    (("URL" . _) #t)
                                    (_ #f)))
                                narinfo)
                        (response-code uncompressed)
                        (match (assq-ref (response-headers uncompressed)
                                         'cache-control)
                          ((('max-age . ttl)) ttl)
                          (_ #f))

                        (string->number
                         (assoc-ref narinfo "FileSize"))
                        (response-code compressed))))))))))

(test-equal "/log/NAME"
  `(200 #t application/x-bzip2)
  (let ((drv (run-with-store %store
               (gexp->derivation "with-log"
                                 #~(call-with-output-file #$output
                                     (lambda (port)
                                       (display "Hello, build log!"
                                                (current-error-port))
                                       (display #$(random-text) port)))))))
    (build-derivations %store (list drv))
    (let* ((response (http-get
                      (publish-uri (string-append "/log/"
                                                  (basename (derivation->output-path drv))))
                      #:decode-body? #f))
           (base     (basename (derivation-file-name drv)))
           (log      (string-append (dirname %state-directory)
                                    "/log/guix/drvs/" (string-take base 2)
                                    "/" (string-drop base 2) ".bz2")))
      (list (response-code response)
            (= (response-content-length response) (stat:size (stat log)))
            (first (response-content-type response))))))

(test-equal "/log/NAME not found"
  404
  (let ((uri (publish-uri "/log/does-not-exist")))
    (response-code (http-get uri))))

(test-equal "non-GET query"
  '(200 404)
  (let ((path (string-append "/" (store-path-hash-part %item)
                             ".narinfo")))
    (map response-code
         (list (http-get (publish-uri path))
               (http-post (publish-uri path))))))

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