[bug#35880] [PATCH 4/7] publish: Add support for lzip.

[Ludovic Courtès]

* guix/scripts/publish.scm (show-help, %options): Support '-C METHOD'
and '-C METHOD:LEVEL'.
(default-compression): New procedure.
(bake-narinfo+nar): Add lzip.
(nar-response-port): Likewise.
(string->compression-type): New procedure.
(make-request-handler): Generalize /nar/gzip handler to handle /nar/lzip
as well.
* tests/publish.scm ("/nar/lzip/*"): New test.
("/*.narinfo with lzip compression"): New test.
* doc/guix.texi (Invoking guix publish): Document it.
(Requirements): Mention lzlib.
---
 .dir-locals.el           |  2 +
 doc/guix.texi            | 25 +++++++++---
 guix/scripts/publish.scm | 84 +++++++++++++++++++++++++++++-----------
 tests/publish.scm        | 36 +++++++++++++++++
 4 files changed, 119 insertions(+), 28 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 550e06ef09..f1196fd781 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -53,6 +53,8 @@
    (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2))
    (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1))
    (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1))
+   (eval . (put 'call-with-lzip-input-port 'scheme-indent-function 1))
+   (eval . (put 'call-with-lzip-output-port 'scheme-indent-function 1))
    (eval . (put 'signature-case 'scheme-indent-function 1))
    (eval . (put 'emacs-batch-eval 'scheme-indent-function 0))
    (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index f176bb0163..b0de5632e7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -757,6 +757,11 @@ Support for build offloading (@pxref{Daemon Offload 
Setup}) and
 @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH},
 version 0.10.2 or later.
 
address@hidden
+When @url{https://www.nongnu.org/lzip/lzlib.html, lzlib} is available, lzlib
+substitutes can be used and @command{guix publish} can compress substitutes
+with lzlib.
+
 @item
 When @url{http://www.bzip.org, libbz2} is available,
 @command{guix-daemon} can use it to compress build logs.
@@ -9656,12 +9661,20 @@ accept connections from any interface.
 Change privileges to @var{user} as soon as possible---i.e., once the
 server socket is open and the signing key has been read.
 
address@hidden address@hidden
address@hidden -C address@hidden
-Compress data using the given @var{level}.  When @var{level} is zero,
-disable compression.  The range 1 to 9 corresponds to different gzip
-compression levels: 1 is the fastest, and 9 is the best (CPU-intensive).
-The default is 3.
address@hidden address@hidden:@var{level}]]
address@hidden -C address@hidden:@var{level}]]
+Compress data using the given @var{method} and @var{level}.  @var{method} is
+one of @code{lzip} and @code{gzip}; when @var{method} is omitted, @code{gzip}
+is used.
+
+When @var{level} is zero, disable compression.  The range 1 to 9 corresponds
+to different compression levels: 1 is the fastest, and 9 is the best
+(CPU-intensive).  The default is 3.
+
+Usually, @code{lzip} compresses noticeably better than @code{gzip} for a small
+increase in CPU usage; see
address@hidden://nongnu.org/lzip/lzip_benchmark.html,benchmarks on the lzip Web
+page}.
 
 Unless @option{--cache} is used, compression occurs on the fly and
 the compressed streams are not
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a236f3e45c..9e74d789ce 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <address@hidden>
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,6 +51,7 @@
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix zlib)
+  #:autoload   (guix lzlib) (lzlib-available?)
   #:use-module (guix cache)
   #:use-module (guix ui)
   #:use-module (guix scripts)
@@ -74,8 +75,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (G_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (G_ "
-  -C, --compression[=LEVEL]
-                         compress archives at LEVEL"))
+  -C, --compression[=METHOD:LEVEL]
+                         compress archives with METHOD at LEVEL"))
   (display (G_ "
   -c, --cache=DIRECTORY  cache published items to DIRECTORY"))
   (display (G_ "
@@ -121,6 +122,9 @@ Publish ~a over HTTP.\n") %store-directory)
   ;; Since we compress on the fly, default to fast compression.
   (compression 'gzip 3))
 
+(define (default-compression type)
+  (compression type 3))
+
 (define (actual-compression item requested)
   "Return the actual compression used for ITEM, which may be %NO-COMPRESSION
 if ITEM is already compressed."
@@ -153,18 +157,28 @@ if ITEM is already compressed."
                             name)))))
         (option '(#\C "compression") #f #t
                 (lambda (opt name arg result)
-                  (match (if arg (string->number* arg) 3)
-                    (0
-                     (alist-cons 'compression %no-compression result))
-                    (level
-                     (if (zlib-available?)
-                         (alist-cons 'compression
-                                     (compression 'gzip level)
-                                     result)
-                         (begin
-                           (warning (G_ "zlib support is missing; \
-compression disabled~%"))
-                           result))))))
+                  (let* ((colon (string-index arg #\:))
+                         (type  (cond
+                                 (colon (string-take arg colon))
+                                 ((string->number arg) "gzip")
+                                 (else arg)))
+                         (level (if colon
+                                    (string->number*
+                                     (string-drop arg (+ 1 colon)))
+                                    (or (string->number arg) 3))))
+                    (match level
+                      (0
+                       (alist-cons 'compression %no-compression result))
+                      (level
+                       (match (string->compression-type type)
+                         ((? symbol? type)
+                          (alist-cons 'compression
+                                      (compression type level)
+                                      result))
+                         (_
+                          (warning (G_ "~a: unsupported compression type~%")
+                                   type)
+                          result)))))))
         (option '(#\c "cache") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'cache arg result)))
@@ -483,6 +497,13 @@ requested using POOL."
          #:level (compression-level compression)
          #:buffer-size (* 128 1024))
        (rename-file (string-append nar ".tmp") nar))
+      ('lzip
+       ;; Note: the file port gets closed along with the lzip port.
+       (call-with-lzip-output-port (open-output-file (string-append nar 
".tmp"))
+         (lambda (port)
+           (write-file item port))
+         #:level (compression-level compression))
+       (rename-file (string-append nar ".tmp") nar))
       ('none
        ;; Cache nars even when compression is disabled so that we can
        ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
@@ -687,6 +708,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
      (make-gzip-output-port (response-port response)
                             #:level level
                             #:buffer-size (* 64 1024)))
+    (($ <compression> 'lzip level)
+     (make-lzip-output-port (response-port response)
+                            #:level level))
     (($ <compression> 'none)
      (response-port response))
     (#f
@@ -761,12 +785,23 @@ blocking."
   http-write
   (@@ (web server http) http-close))
 
+(define (string->compression-type string)
+  "Return a symbol denoting the compression method expressed by STRING; return
+#f if STRING doesn't match any supported method."
+  (match string
+    ("gzip" (and (zlib-available?) 'gzip))
+    ("lzip" (and (lzlib-available?) 'lzip))
+    (_      #f)))
+
 (define* (make-request-handler store
                                #:key
                                cache pool
                                narinfo-ttl
                                (nar-path "nar")
                                (compression %no-compression))
+  (define compression-type?
+    string->compression-type)
+
   (define nar-path?
     (let ((expected (split-and-decode-uri-path nar-path)))
       (cut equal? expected <>)))
@@ -815,13 +850,18 @@ blocking."
           ;; is restarted with different compression parameters.
 
           ;; /nar/gzip/<store-item>
-          ((components ... "gzip" store-item)
-           (if (and (nar-path? components) (zlib-available?))
-               (let ((compression (match compression
-                                    (($ <compression> 'gzip)
-                                     compression)
-                                    (_
-                                     %default-gzip-compression))))
+          ((components ... (? compression-type? type) store-item)
+           (if (nar-path? components)
+               (let* ((compression-type (string->compression-type type))
+                      (compression (match compression
+                                     (($ <compression> type)
+                                      (if (eq? type compression-type)
+                                          compression
+                                          (default-compression
+                                            compression-type)))
+                                     (_
+                                      (default-compression
+                                        compression-type)))))
                  (if cache
                      (render-nar/cached store cache request store-item
                                         #:ttl narinfo-ttl
diff --git a/tests/publish.scm b/tests/publish.scm
index 097ac036e0..10bc859695 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -36,6 +36,7 @@
   #:use-module (gcrypt pk-crypto)
   #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
   #:use-module (guix zlib)
+  #:use-module (guix lzlib)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web response)
@@ -229,6 +230,19 @@ FileSize: ~a~%"
                (string-append "/nar/gzip/" (basename %item))))))
     (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))
 
+(unless (lzlib-available?)
+  (test-skip 1))
+(test-equal "/nar/lzip/*"
+  "bar"
+  (call-with-temporary-output-file
+   (lambda (temp port)
+     (let ((nar (http-get-port
+                 (publish-uri
+                  (string-append "/nar/lzip/" (basename %item))))))
+       (call-with-lzip-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"
@@ -251,6 +265,28 @@ FileSize: ~a~%"
                   (_ #f)))
               (recutils->alist body)))))
 
+(unless (lzlib-available?)
+  (test-skip 1))
+(test-equal "/*.narinfo with lzip compression"
+  `(("StorePath" . ,%item)
+    ("URL" . ,(string-append "nar/lzip/" (basename %item)))
+    ("Compression" . "lzip"))
+  (let ((thread (with-separate-output-ports
+                 (call-with-new-thread
+                  (lambda ()
+                    (guix-publish "--port=6790" "-Clzip"))))))
+    (wait-until-ready 6790)
+    (let* ((url  (string-append "http://localhost:6790/";
+                                (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"
-- 
2.21.0