diff options
| -rw-r--r-- | doc/guix.texi | 12 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 163 | ||||
| -rw-r--r-- | tests/publish.scm | 59 |
3 files changed, 203 insertions, 31 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index a2732deded..6e8fb483f2 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. +@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 diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e419..3e1ecb9d1b 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 d6d537c58a..9bf181f1fc 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!"))) |