;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@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 (guix hash)
  #:use-</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=2766235f30159fdd669985428da80911b20c288b'>refs</a><a href='/guix/log/gnu.scm'>log</a><a href='/guix/tree/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>tree</a><a class='active' href='/guix/commit/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>commit</a><a href='/guix/diff/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu.scm'>
<input type='hidden' name='id' value='2766235f30159fdd669985428da80911b20c288b'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=2766235f30159fdd669985428da80911b20c288b'>root</a>/<a href='/guix/commit/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>gnu.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='2766235f30159fdd669985428da80911b20c288b'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>Ricardo Wurmus &lt;rekado@elephly.net&gt;</td><td class='right'>2022-11-04 00:05:53 +0100</td></tr>
<tr><th>committer</th><td>Ricardo Wurmus &lt;rekado@elephly.net&gt;</td><td class='right'>2022-11-04 10:01:05 +0100</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>2766235f30159fdd669985428da80911b20c288b</a> (<a href='/guix/patch/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=2766235f30159fdd669985428da80911b20c288b'>676d0038e19a9cc5ee3d6971195c04ed5d905217</a> /<a href='/guix/tree/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b'>gnu.scm</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/gnu.scm?id=90d7dd19670471a4636e80c31147cce3a7475720'>90d7dd19670471a4636e80c31147cce3a7475720</a> (<a href='/guix/diff/gnu.scm?id=2766235f30159fdd669985428da80911b20c288b&amp;id2=90d7dd19670471a4636e80c31147cce3a7475720'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-2766235f30159fdd669985428da80911b20c288b.tar.gz'>guix-2766235f30159fdd669985428da80911b20c288b.tar.gz</a><br/><a href='/guix/snapshot/guix-2766235f30159fdd669985428da80911b20c288b.zip'>guix-2766235f30159fdd669985428da80911b20c288b.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: liblantern: Update to 0.9.0.</div><div class='commit-msg'>* gnu/packages/machine-learning.scm (liblantern): Update to 0.9.0.
</div><div class='diffstat-header'><a href='/guix/diff/?id=2766235f30159fdd669985428da80911b20c288b'>Diffstat</a> (limited to 'gnu.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
                  (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 "/*.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
        200)                                      ;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 #f
          `(("StorePath" . ,item)
            ("URL" . ,(string-append "nar/" (basename item)))
            ("Compression" . "none"))
          200                                     ;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"
                                       (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* ((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)
                        (filter (lambda (item)
                                  (match item
                                    (("Compression" . _) #t)
                                    (("StorePath" . _)  #t)
                                    (("URL" . _) #t)
                                    (_ #f)))
                                narinfo)
                        (response-code uncompressed)
                        (string->number
                         (assoc-ref narinfo "FileSize"))
                        (response-code compressed))))))))))

(test-end "publish")