[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: publish: Add '--compression'.
|
From: |
Ludovic Courtès |
|
Subject: |
03/03: publish: Add '--compression'. |
|
Date: |
Mon, 18 Jul 2016 22:07:41 +0000 (UTC) |
civodul pushed a commit to branch master
in repository guix.
commit 4a1fc562ae5eedf40f6ae4eabe30580b0983b8f6
Author: Ludovic Courtès <address@hidden>
Date: Mon Jul 18 23:58:34 2016 +0200
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.
---
doc/guix.texi | 12 ++++
guix/scripts/publish.scm | 163 +++++++++++++++++++++++++++++++++++++++-------
tests/publish.scm | 59 +++++++++++++++--
3 files changed, 203 insertions(+), 31 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index a2732de..6e8fb48 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5644,6 +5644,18 @@ 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.
+
+Note compression occurs on the fly and the compressed streams are not
+cached. Thus, to reduce load on the machine that runs @command{guix
+publish}, it may be a good idea to choose a low compression level, or to
+run @command{guix publish} behind a caching proxy.
+
@item address@hidden
Produce @code{Cache-Control} HTTP headers that advertise a time-to-live
(TTL) of @var{ttl}. @var{ttl} must denote a duration: @code{5d} means 5
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 4c0aa8e..3e1ecb9 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -27,6 +27,7 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
@@ -45,6 +46,7 @@
#:use-module (guix pk-crypto)
#:use-module (guix store)
#:use-module (guix serialization)
+ #:use-module (guix zlib)
#:use-module (guix ui)
#:use-module (guix scripts)
#:export (guix-publish))
@@ -59,6 +61,9 @@ Publish ~a over HTTP.\n") %store-directory)
(display (_ "
-u, --user=USER change privileges to USER as soon as possible"))
(display (_ "
+ -C, --compression[=LEVEL]
+ compress archives at LEVEL"))
+ (display (_ "
--ttl=TTL announce narinfos can be cached for TTL seconds"))
(display (_ "
-r, --repl[=PORT] spawn REPL server on PORT"))
@@ -79,6 +84,20 @@ Publish ~a over HTTP.\n") %store-directory)
(leave (_ "lookup of host '~a' failed: ~a~%")
host (gai-strerror error)))))
+;; Nar compression parameters.
+(define-record-type <compression>
+ (compression type level)
+ compression?
+ (type compression-type)
+ (level compression-level))
+
+(define %no-compression
+ (compression 'none 0))
+
+(define %default-gzip-compression
+ ;; Since we compress on the fly, default to fast compression.
+ (compression 'gzip 3))
+
(define %options
(list (option '(#\h "help") #f #f
(lambda _
@@ -102,6 +121,14 @@ Publish ~a over HTTP.\n") %store-directory)
(()
(leave (_ "lookup of host '~a' returned nothing")
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
+ (alist-cons 'compression (compression 'gzip level)
+ result)))))
(option '("ttl") #t #f
(lambda (opt name arg result)
(let ((duration (string->duration arg)))
@@ -117,6 +144,12 @@ Publish ~a over HTTP.\n") %store-directory)
(define %default-options
`((port . 8080)
+
+ ;; Default to fast & low compression.
+ (compression . ,(if (zlib-available?)
+ %default-gzip-compression
+ %no-compression))
+
(address . ,(make-socket-address AF_INET INADDR_ANY 0))
(repl . #f)))
@@ -152,12 +185,20 @@ Publish ~a over HTTP.\n") %store-directory)
(define base64-encode-string
(compose base64-encode string->utf8))
-(define (narinfo-string store store-path key)
+(define* (narinfo-string store store-path key
+ #:key (compression %no-compression))
"Generate a narinfo key/value string for STORE-PATH; an exception is raised
-if STORE-PATH is invalid. The narinfo is signed with KEY."
+if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The
+narinfo is signed with KEY."
(let* ((path-info (query-path-info store store-path))
- (url (encode-and-join-uri-path (list "nar"
- (basename store-path))))
+ (url (encode-and-join-uri-path
+ `("nar"
+ ,@(match compression
+ (($ <compression> 'none)
+ '())
+ (($ <compression> type)
+ (list (symbol->string type))))
+ ,(basename store-path))))
(hash (bytevector->nix-base32-string
(path-info-hash path-info)))
(size (path-info-nar-size path-info))
@@ -166,13 +207,16 @@ if STORE-PATH is invalid. The narinfo is signed with
KEY."
" "))
(deriver (path-info-deriver path-info))
(base-info (format #f
- "StorePath: ~a
+ "\
+StorePath: ~a
URL: ~a
-Compression: none
+Compression: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
- store-path url hash size references))
+ store-path url
+ (compression-type compression)
+ hash size references))
;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation.
(info (if (not deriver)
@@ -209,7 +253,8 @@ References: ~a~%"
(format port "~a: ~a~%" key value)))
%nix-cache-info))))
-(define* (render-narinfo store request hash #:key ttl)
+(define* (render-narinfo store request hash
+ #:key ttl (compression %no-compression))
"Render metadata for the store path corresponding to HASH. If TTL is true,
advertise it as the maximum validity period (in seconds) via the
'Cache-Control' header. This allows 'guix substitute' to cache it for an
@@ -222,18 +267,35 @@ appropriate duration."
`((cache-control (max-age . ,ttl)))
'()))
(cut display
- (narinfo-string store store-path (force %private-key))
- <>)))))
-
-(define (render-nar store request store-item)
+ (narinfo-string store store-path (force %private-key)
+ #:compression compression)
+ <>)))))
+
+;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
+;; internal consumption: it allows us to pass the compression info to
+;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
+(declare-header! "Guix-Nar-Compression"
+ (lambda (str)
+ (match (call-with-input-string str read)
+ (('compression type level)
+ (compression type level))))
+ compression?
+ (lambda (compression port)
+ (match compression
+ (($ <compression> type level)
+ (write `(compression ,type ,level) port)))))
+
+(define* (render-nar store request store-item
+ #:key (compression %no-compression))
"Render archive of the store path corresponding to STORE-ITEM."
(let ((store-path (string-append %store-directory "/" store-item)))
;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
;; sequences.
(if (valid-path? store store-path)
- (values '((content-type . (application/x-nix-archive
- (charset . "ISO-8859-1"))))
+ (values `((content-type . (application/x-nix-archive
+ (charset . "ISO-8859-1")))
+ (guix-nar-compression . ,compression))
;; XXX: We're not returning the actual contents, deferring
;; instead to 'http-write'. This is a hack to work around
;; <http://bugs.gnu.org/21093>.
@@ -282,6 +344,28 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
(values)
(apply throw args)))))
+(define-syntax-rule (swallow-zlib-error exp ...)
+ "Swallow 'zlib-error' exceptions raised by EXP..."
+ (catch 'zlib-error
+ (lambda ()
+ exp ...)
+ (const #f)))
+
+(define (nar-response-port response)
+ "Return a port on which to write the body of RESPONSE, the response of a
+/nar request, according to COMPRESSION."
+ (match (assoc-ref (response-headers response) 'guix-nar-compression)
+ (($ <compression> 'gzip level)
+ ;; Note: We cannot used chunked encoding here because
+ ;; 'make-gzip-output-port' wants a file port.
+ (make-gzip-output-port (response-port response)
+ #:level level
+ #:buffer-size (* 64 1024)))
+ (($ <compression> 'none)
+ (response-port response))
+ (#f
+ (response-port response))))
+
(define (http-write server client response body)
"Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
blocking."
@@ -293,16 +377,20 @@ blocking."
(lambda ()
(let* ((response (write-response (sans-content-length response)
client))
- (port (response-port response)))
+ (port (begin
+ (force-output client)
+ (nar-response-port response))))
;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
;; 'render-nar', BODY here is just the file name of the store item.
;; We call 'write-file' from here because we know that's the only
;; way to avoid building the whole nar in memory, which could
;; quickly become a real problem. As a bonus, we even do
;; sendfile(2) directly from the store files to the socket.
- (swallow-EPIPE
- (write-file (utf8->string body) port))
- (close-port port)
+ (swallow-zlib-error
+ (swallow-EPIPE
+ (write-file (utf8->string body) port)))
+ (swallow-zlib-error
+ (close-port port))
(values)))))
(_
;; Handle other responses sequentially.
@@ -316,7 +404,10 @@ blocking."
http-write
(@@ (web server http) http-close))
-(define* (make-request-handler store #:key narinfo-ttl)
+(define* (make-request-handler store
+ #:key
+ narinfo-ttl
+ (compression %no-compression))
(lambda (request body)
(format #t "~a ~a~%"
(request-method request)
@@ -330,16 +421,37 @@ blocking."
(((= extract-narinfo-hash (? string? hash)))
;; TODO: Register roots for HASH that will somehow remain for
;; NARINFO-TTL.
- (render-narinfo store request hash #:ttl narinfo-ttl))
+ (render-narinfo store request hash
+ #:ttl narinfo-ttl
+ #:compression compression))
+
+ ;; Use different URLs depending on the compression type. This
+ ;; guarantees that /nar URLs remain valid even when 'guix publish'
+ ;; is restarted with different compression parameters.
+
;; /nar/<store-item>
(("nar" store-item)
- (render-nar store request store-item))
+ (render-nar store request store-item
+ #:compression %no-compression))
+ ;; /nar/gzip/<store-item>
+ (("nar" "gzip" store-item)
+ (if (zlib-available?)
+ (render-nar store request store-item
+ #:compression
+ (match compression
+ (($ <compression> 'gzip)
+ compression)
+ (_
+ %default-gzip-compression)))
+ (not-found request)))
(_ (not-found request)))
(not-found request))))
(define* (run-publish-server socket store
- #:key narinfo-ttl)
- (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl)
+ #:key (compression %no-compression) narinfo-ttl)
+ (run-server (make-request-handler store
+ #:narinfo-ttl narinfo-ttl
+ #:compression compression)
concurrent-http-server
`(#:socket ,socket)))
@@ -378,6 +490,7 @@ blocking."
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
(ttl (assoc-ref opts 'narinfo-ttl))
+ (compression (assoc-ref opts 'compression))
(address (let ((addr (assoc-ref opts 'address)))
(make-socket-address (sockaddr:fam addr)
(sockaddr:addr addr)
@@ -404,4 +517,6 @@ consider using the '--user' option!~%")))
(when repl-port
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
(with-store store
- (run-publish-server socket store #:narinfo-ttl ttl)))))
+ (run-publish-server socket store
+ #:compression compression
+ #:narinfo-ttl ttl)))))
diff --git a/tests/publish.scm b/tests/publish.scm
index d6d537c..9bf181f 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!")))