publish: Add '--compression'.

* guix/scripts/publish.scm (show-help, %options): Add '--compression'.
(<compression>): New record type.
(%no-compression, %default-gzip-compression): New variables.
(%default-options): Add 'compression' key.
(narinfo-string): Add #:compression parameter and honor it.
(render-narinfo): Likewise.
(render-nar): Likewise.
<top level>: Add call to 'declare-header!'.
(swallow-zlib-error): New macro.
(nar-response-port): New procedure.
(http-write): Add call to 'force-output'.  Use 'nar-response-port'
instead of 'response-port'.  Use 'swallow-zlib-error'.
(make-request-handler): Add #:compression parameter and honor it.  Add
"nar/gzip" URL handler.
(run-publish-server): Add #:compression parameter and honor it.
(guix-publish): Honor --compression.
* tests/publish.scm (http-get-port, wait-until-ready): New procedures.
<top level>: Run main server with "-C0".  Call 'wait-until-ready'.
("/nar/gzip/*", "/*.narinfo with compression"): New tests.
* doc/guix.texi (Invoking guix publish): Document it.

1 files changed, 52 insertions, 7 deletions

diff --git a/tests/publish.scm b/tests/publish.scm
index d6d537c58a..9bf181f1fc 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -28,12 +28,15 @@
   #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix base64)
+  #:use-module ((guix records) #:select (recutils->alist))
   #:use-module ((guix serialization) #:select (restore-file))
   #:use-module (guix pk-crypto)
+  #: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)
@@ -52,20 +55,28 @@
   (call-with-values (lambda () (http-get uri))
     (lambda (response body) body)))
 
+(define (http-get-port uri)
+  (call-with-values (lambda () (http-get uri #:streaming? #t))
+    (lambda (response port) port)))
+
 (define (publish-uri route)
   (string-append "http://localhost:6789" route))
 
 ;; Run a local publishing server in a separate thread.
 (call-with-new-thread
  (lambda ()
-   (guix-publish "--port=6789"))) ; attempt to avoid port collision
+   (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)))))
 
-;; 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") 6789))
-      (loop))))
+;; Wait until the two servers are ready.
+(wait-until-ready 6789)
 
 
 (test-begin "publish")
@@ -145,6 +156,40 @@ References: ~%"
        (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 (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)))))
+
 (test-equal "/nar/ with properly encoded '+' sign"
   "Congrats!"
   (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))