From patchwork Fri May 24 13:42:35 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 14064 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A7AC717041; Fri, 24 May 2019 14:44:18 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-0.2 required=5.0 tests=BAYES_00,URIBL_BLOCKED, URIBL_SBL,URIBL_SBL_A autolearn=no autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 340291700D for ; Fri, 24 May 2019 14:44:15 +0100 (BST) Received: from localhost ([127.0.0.1]:54904 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hUAUY-0000G2-RD for patchwork@mira.cbaines.net; Fri, 24 May 2019 09:44:14 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37116) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hUAUO-000097-4n for guix-patches@gnu.org; Fri, 24 May 2019 09:44:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hUAUM-0000X3-9D for guix-patches@gnu.org; Fri, 24 May 2019 09:44:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:61000) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hUAUM-0000Wv-6G for guix-patches@gnu.org; Fri, 24 May 2019 09:44:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hUAUM-0002Rn-1k for guix-patches@gnu.org; Fri, 24 May 2019 09:44:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#35880] [PATCH 4/7] publish: Add support for lzip. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 24 May 2019 13:44:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 35880 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 35880@debbugs.gnu.org Received: via spool by 35880-submit@debbugs.gnu.org id=B35880.15587053849297 (code B ref 35880); Fri, 24 May 2019 13:44:02 +0000 Received: (at 35880) by debbugs.gnu.org; 24 May 2019 13:43:04 +0000 Received: from localhost ([127.0.0.1]:46304 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hUATO-0002PZ-U8 for submit@debbugs.gnu.org; Fri, 24 May 2019 09:43:03 -0400 Received: from eggs.gnu.org ([209.51.188.92]:50670) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hUATH-0002Nz-64 for 35880@debbugs.gnu.org; Fri, 24 May 2019 09:42:55 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:38750) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hUATC-0008EC-1C; Fri, 24 May 2019 09:42:50 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=36484 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hUATB-0007iN-Ea; Fri, 24 May 2019 09:42:49 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 24 May 2019 15:42:35 +0200 Message-Id: <20190524134238.22802-4-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190524134238.22802-1-ludo@gnu.org> References: <20190524134238.22802-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Pierre Neidhardt Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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. +@item +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. -@item --compression[=@var{level}] -@itemx -C [@var{level}] -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. +@item --compression[=@var{method}[:@var{level}]] +@itemx -C [@var{method}[:@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 +@uref{https://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 -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; 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 .) @@ -687,6 +708,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (make-gzip-output-port (response-port response) #:level level #:buffer-size (* 64 1024))) + (($ 'lzip level) + (make-lzip-output-port (response-port response) + #:level level)) (($ '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/ - ((components ... "gzip" store-item) - (if (and (nar-path? components) (zlib-available?)) - (let ((compression (match 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 + (($ 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"