futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

publish: Add '--compression'.

Browse Source 
* 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.
This commit is contained in:
Ludovic Courtès 2016-07-18 23:58:34 +02:00
parent 721539026d
commit 4a1fc562ae
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 202 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
doc/guix.texi
View File

@ -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.
@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.
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 --ttl=@var{ttl}
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

161
guix/scripts/publish.scm
View File

@ -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))
@ -58,6 +60,9 @@ Publish ~a over HTTP.\n") %store-directory)
--listen=HOST listen on the network interface for HOST"))
(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 (_ "
@ -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))
<>)))))
(narinfo-string store store-path (force %private-key)
#:compression compression)
<>)))))
(define (render-nar store request store-item)
;; 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)))))

59
tests/publish.scm
View File

@ -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
;; 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))))
(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 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!")))