summaryrefslogtreecommitdiff
path: root/guix/scripts/publish.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-05-24 08:26:38 +0200
committerLudovic Courtès <ludo@gnu.org>2019-05-27 22:47:24 +0200
commit66229b04ae0ee05779b93d77900a062b8e0e8770 (patch)
tree05706120a2cc22bb9120169bae7dbf5f261e54b5 /guix/scripts/publish.scm
parent4e48923e7523c863996bb616c6abb7e4cb78a3b5 (diff)
publish: Add support for lzip.
* 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.
Diffstat (limited to 'guix/scripts/publish.scm')
-rw-r--r--guix/scripts/publish.scm84
1 files changed, 62 insertions, 22 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index db64d6483e..11e7e985d1 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 <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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)))
@@ -511,6 +525,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>.)
@@ -715,6 +736,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
@@ -789,12 +813,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 <>)))
@@ -843,13 +878,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