nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

publish: '--compression' can be repeated. 

This allows 'guix publish' to compress and advertise multiple
compression methods from which users can choose.

* guix/scripts/publish.scm (actual-compression): Rename to...
(actual-compressions): ... this.  Expect REQUESTED to be a list, and
always return a list.
(%default-options): Remove 'compression.
(store-item->recutils): New procedure.
(narinfo-string): Change #:compression to #:compressions (plural).
Adjust accordingly.
(render-narinfo, render-narinfo/cached): Likewise.
(bake-narinfo+nar): Change #:compression to #:compressions.
[compressed-nar-size]: New procedure.
Call 'compress-nar' for each item returned by 'actual-compressions'.
Create a narinfo for each compression.
(effective-compression): New procedure.
(make-request-handler): Change #:compression to #:compressions.
Use 'effective-compression' to determine the applicable compression.
(guix-publish): Adjust handling of '--compression'.
Print a message for each compression that is enabled.
* tests/publish.scm ("/*.narinfo"): Adjust to new narinfo field
ordering.
("/*.narinfo with properly encoded '+' sign"): Likewise.
("/*.narinfo with lzip + gzip"): New test.
("with cache, lzip + gzip"): New test.
* doc/guix.texi (Invoking guix publish): Document it.
This commit is contained in:
Ludovic Courtès 2019-05-30 18:36:37 +02:00
parent dec4b3aa18
commit b8fa86adfc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 210 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
doc/guix.texi
View File

@ -9685,6 +9685,11 @@ run @command{guix publish} behind a caching proxy, or to use
allows @command{guix publish} to add @code{Content-Length} HTTP header allows @command{guix publish} to add @code{Content-Length} HTTP header
to its responses. to its responses.
This option can be repeated, in which case every substitute gets compressed
using all the selected methods, and all of them are advertised. This is
useful when users may not support all the compression methods: they can select
the one they support.
@item --cache=@var{directory} @item --cache=@var{directory}
@itemx -c @var{directory} @itemx -c @var{directory}
Cache archives and meta-data (@code{.narinfo} URLs) to @var{directory} Cache archives and meta-data (@code{.narinfo} URLs) to @var{directory}

176
guix/scripts/publish.scm
View File

@ -125,11 +125,11 @@ Publish ~a over HTTP.\n") %store-directory)
(define (default-compression type) (define (default-compression type)
(compression type 3)) (compression type 3))
(define (actual-compression item requested) (define (actual-compressions item requested)
"Return the actual compression used for ITEM, which may be %NO-COMPRESSION "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION
if ITEM is already compressed." if ITEM is already compressed."
(if (compressed-file? item) (if (compressed-file? item)
%no-compression (list %no-compression)
requested)) requested))
(define %options (define %options
@ -217,11 +217,6 @@ if ITEM is already compressed."
(public-key-file . ,%public-key-file) (public-key-file . ,%public-key-file)
(private-key-file . ,%private-key-file) (private-key-file . ,%private-key-file)
;; Default to fast & low compression.
(compression . ,(if (zlib-available?)
%default-gzip-compression
%no-compression))
;; Default number of workers when caching is enabled. ;; Default number of workers when caching is enabled.
(workers . ,(current-processor-count)) (workers . ,(current-processor-count))
@ -249,29 +244,40 @@ if ITEM is already compressed."
(define base64-encode-string (define base64-encode-string
(compose base64-encode string->utf8)) (compose base64-encode string->utf8))
(define* (narinfo-string store store-path key (define* (store-item->recutils store-item
#:key (compression %no-compression) #:key
(nar-path "nar") file-size) (nar-path "nar")
"Generate a narinfo key/value string for STORE-PATH; an exception is raised (compression %no-compression)
if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The file-size)
narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs. "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM,
Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it with COMPRESSION, starting at NAR-PATH."
informs the client of how much needs to be downloaded." (let ((url (encode-and-join-uri-path
(let* ((path-info (query-path-info store store-path))
(compression (actual-compression store-path compression))
(url (encode-and-join-uri-path
`(,@(split-and-decode-uri-path nar-path) `(,@(split-and-decode-uri-path nar-path)
,@(match compression ,@(match compression
(($ <compression> 'none) (($ <compression> 'none)
'()) '())
(($ <compression> type) (($ <compression> type)
(list (symbol->string type)))) (list (symbol->string type))))
,(basename store-path)))) ,(basename store-item)))))
(format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]"
url (compression-type compression) file-size)))
(define* (narinfo-string store store-path key
#:key (compressions (list %no-compression))
(nar-path "nar") (file-sizes '()))
"Generate a narinfo key/value string for STORE-PATH; an exception is raised
if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The
narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs.
Optionally, FILE-SIZES is a list of compression/integer pairs, where the
integer is size in bytes of the compressed NAR; it informs the client of how
much needs to be downloaded."
(let* ((path-info (query-path-info store store-path))
(compressions (actual-compressions store-path compressions))
(hash (bytevector->nix-base32-string (hash (bytevector->nix-base32-string
(path-info-hash path-info))) (path-info-hash path-info)))
(size (path-info-nar-size path-info)) (size (path-info-nar-size path-info))
(file-size (or file-size (file-sizes `((,%no-compression . ,size) ,@file-sizes))
(and (eq? compression %no-compression) size)))
(references (string-join (references (string-join
(map basename (path-info-references path-info)) (map basename (path-info-references path-info))
" ")) " "))
@ -279,17 +285,21 @@ informs the client of how much needs to be downloaded."
(base-info (format #f (base-info (format #f
"\ "\
StorePath: ~a StorePath: ~a
URL: ~a ~{~a~}\
Compression: ~a
NarHash: sha256:~a NarHash: sha256:~a
NarSize: ~d NarSize: ~d
References: ~a~%~a" References: ~a~%"
store-path url store-path
(compression-type compression) (map (lambda (compression)
hash size references (let ((size (assoc-ref file-sizes
(if file-size compression)))
(format #f "FileSize: ~a~%" file-size) (store-item->recutils store-path
""))) #:file-size size
#:nar-path nar-path
#:compression
compression)))
compressions)
hash size references))
;; Do not render a "Deriver" or "System" line if we are rendering ;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation. ;; info for a derivation.
(info (if (not deriver) (info (if (not deriver)
@ -332,7 +342,7 @@ References: ~a~%~a"
%nix-cache-info)))) %nix-cache-info))))
(define* (render-narinfo store request hash (define* (render-narinfo store request hash
#:key ttl (compression %no-compression) #:key ttl (compressions (list %no-compression))
(nar-path "nar")) (nar-path "nar"))
"Render metadata for the store path corresponding to HASH. If TTL is true, "Render metadata for the store path corresponding to HASH. If TTL is true,
advertise it as the maximum validity period (in seconds) via the advertise it as the maximum validity period (in seconds) via the
@ -348,7 +358,7 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(cut display (cut display
(narinfo-string store store-path (%private-key) (narinfo-string store store-path (%private-key)
#:nar-path nar-path #:nar-path nar-path
#:compression compression) #:compressions compressions)
<>))))) <>)))))
(define* (nar-cache-file directory item (define* (nar-cache-file directory item
@ -442,7 +452,7 @@ vanished from the store in the meantime."
(apply throw args)))))) (apply throw args))))))
(define* (render-narinfo/cached store request hash (define* (render-narinfo/cached store request hash
#:key ttl (compression %no-compression) #:key ttl (compressions (list %no-compression))
(nar-path "nar") (nar-path "nar")
cache pool) cache pool)
"Respond to the narinfo request for REQUEST. If the narinfo is available in "Respond to the narinfo request for REQUEST. If the narinfo is available in
@ -461,10 +471,11 @@ requested using POOL."
(delete-file* mapping))) (delete-file* mapping)))
(let* ((item (hash-part->path* store hash cache)) (let* ((item (hash-part->path* store hash cache))
(compression (actual-compression item compression)) (compressions (actual-compressions item compressions))
(cached (and (not (string-null? item)) (cached (and (not (string-null? item))
(narinfo-cache-file cache item (narinfo-cache-file cache item
#:compression compression)))) #:compression
(first compressions)))))
(cond ((string-null? item) (cond ((string-null? item)
(not-found request)) (not-found request))
((file-exists? cached) ((file-exists? cached)
@ -488,7 +499,7 @@ requested using POOL."
;; (format #t "baking ~s~%" item) ;; (format #t "baking ~s~%" item)
(bake-narinfo+nar cache item (bake-narinfo+nar cache item
#:ttl ttl #:ttl ttl
#:compression compression #:compressions compressions
#:nar-path nar-path))) #:nar-path nar-path)))
(when ttl (when ttl
@ -535,30 +546,45 @@ requested using POOL."
(write-file item port)))))) (write-file item port))))))
(define* (bake-narinfo+nar cache item (define* (bake-narinfo+nar cache item
#:key ttl (compression %no-compression) #:key ttl (compressions (list %no-compression))
(nar-path "/nar")) (nar-path "/nar"))
"Write the narinfo and nar for ITEM to CACHE." "Write the narinfo and nar for ITEM to CACHE."
(let* ((compression (actual-compression item compression)) (define (compressed-nar-size compression)
(nar (nar-cache-file cache item (let* ((nar (nar-cache-file cache item #:compression compression))
#:compression compression)) (stat (stat nar #f)))
(narinfo (narinfo-cache-file cache item (and stat
#:compression compression))) (cons compression (stat:size stat)))))
(compress-nar cache item compression)
(mkdir-p (dirname narinfo)) (let ((compression (actual-compressions item compressions)))
(for-each (cut compress-nar cache item <>) compressions)
(match compressions
((main others ...)
(let ((narinfo (narinfo-cache-file cache item
#:compression main)))
(with-atomic-file-output narinfo (with-atomic-file-output narinfo
(lambda (port) (lambda (port)
;; Open a new connection to the store. We cannot reuse the main ;; Open a new connection to the store. We cannot reuse the main
;; thread's connection to the store since we would end up sending ;; thread's connection to the store since we would end up sending
;; stuff concurrently on the same channel. ;; stuff concurrently on the same channel.
(with-store store (with-store store
(let ((sizes (filter-map compressed-nar-size compression)))
(display (narinfo-string store item (display (narinfo-string store item
(%private-key) (%private-key)
#:nar-path nar-path #:nar-path nar-path
#:compression compression #:compressions compressions
#:file-size (and=> (stat nar #f) #:file-sizes sizes)
stat:size)) port)))))
port))))))
;; Make narinfo files for OTHERS hard links to NARINFO such that the
;; atime-based cache eviction considers either all the nars or none
;; of them as candidates.
(for-each (lambda (other)
(let ((other (narinfo-cache-file cache item
#:compression other)))
(link narinfo other)))
others))))))
;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
;; internal consumption: it allows us to pass the compression info to ;; internal consumption: it allows us to pass the compression info to
@ -827,12 +853,22 @@ blocking."
("lzip" (and (lzlib-available?) 'lzip)) ("lzip" (and (lzlib-available?) 'lzip))
(_ #f))) (_ #f)))
(define (effective-compression requested-type compressions)
"Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION
methods, return the applicable compression."
(or (find (match-lambda
(($ <compression> type)
(and (eq? type requested-type)
compression)))
compressions)
(default-compression requested-type)))
(define* (make-request-handler store (define* (make-request-handler store
#:key #:key
cache pool cache pool
narinfo-ttl narinfo-ttl
(nar-path "nar") (nar-path "nar")
(compression %no-compression)) (compressions (list %no-compression)))
(define compression-type? (define compression-type?
string->compression-type) string->compression-type)
@ -860,11 +896,11 @@ blocking."
#:pool pool #:pool pool
#:ttl narinfo-ttl #:ttl narinfo-ttl
#:nar-path nar-path #:nar-path nar-path
#:compression compression) #:compressions compressions)
(render-narinfo store request hash (render-narinfo store request hash
#:ttl narinfo-ttl #:ttl narinfo-ttl
#:nar-path nar-path #:nar-path nar-path
#:compression compression))) #:compressions compressions)))
;; /nar/file/NAME/sha256/HASH ;; /nar/file/NAME/sha256/HASH
(("file" name "sha256" hash) (("file" name "sha256" hash)
(guard (c ((invalid-base32-character? c) (guard (c ((invalid-base32-character? c)
@ -885,15 +921,8 @@ blocking."
((components ... (? compression-type? type) store-item) ((components ... (? compression-type? type) store-item)
(if (nar-path? components) (if (nar-path? components)
(let* ((compression-type (string->compression-type type)) (let* ((compression-type (string->compression-type type))
(compression (match compression (compression (effective-compression compression-type
(($ <compression> type) compressions)))
(if (eq? type compression-type)
compression
(default-compression
compression-type)))
(_
(default-compression
compression-type)))))
(if cache (if cache
(render-nar/cached store cache request store-item (render-nar/cached store cache request store-item
#:ttl narinfo-ttl #:ttl narinfo-ttl
@ -917,7 +946,8 @@ blocking."
(not-found request)))) (not-found request))))
(define* (run-publish-server socket store (define* (run-publish-server socket store
#:key (compression %no-compression) #:key
(compressions (list %no-compression))
(nar-path "nar") narinfo-ttl (nar-path "nar") narinfo-ttl
cache pool) cache pool)
(run-server (make-request-handler store (run-server (make-request-handler store
@ -925,7 +955,7 @@ blocking."
#:pool pool #:pool pool
#:nar-path nar-path #:nar-path nar-path
#:narinfo-ttl narinfo-ttl #:narinfo-ttl narinfo-ttl
#:compression compression) #:compressions compressions)
concurrent-http-server concurrent-http-server
`(#:socket ,socket))) `(#:socket ,socket)))
@ -964,7 +994,17 @@ blocking."
(user (assoc-ref opts 'user)) (user (assoc-ref opts 'user))
(port (assoc-ref opts 'port)) (port (assoc-ref opts 'port))
(ttl (assoc-ref opts 'narinfo-ttl)) (ttl (assoc-ref opts 'narinfo-ttl))
(compression (assoc-ref opts 'compression)) (compressions (match (filter-map (match-lambda
(('compression . compression)
compression)
(_ #f))
opts)
(()
;; Default to fast & low compression.
(list (if (zlib-available?)
%default-gzip-compression
%no-compression)))
(lst (reverse lst))))
(address (let ((addr (assoc-ref opts 'address))) (address (let ((addr (assoc-ref opts 'address)))
(make-socket-address (sockaddr:fam addr) (make-socket-address (sockaddr:fam addr)
(sockaddr:addr addr) (sockaddr:addr addr)
@ -996,9 +1036,11 @@ consider using the '--user' option!~%")))
(inet-ntop (sockaddr:fam address) (sockaddr:addr address)) (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
(sockaddr:port address)) (sockaddr:port address))
(when compression (for-each (lambda (compression)
(info (G_ "using '~a' compression method, level ~a~%") (info (G_ "using '~a' compression method, level ~a~%")
(compression-type compression) (compression-level compression))) (compression-type compression)
(compression-level compression)))
compressions)
(when repl-port (when repl-port
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
@ -1013,7 +1055,7 @@ consider using the '--user' option!~%")))
#:thread-name #:thread-name
"publish worker")) "publish worker"))
#:nar-path nar-path #:nar-path nar-path
#:compression compression #:compressions compressions
#:narinfo-ttl ttl)))))) #:narinfo-ttl ttl))))))
;;; Local Variables: ;;; Local Variables:

89
tests/publish.scm
View File

@ -138,17 +138,17 @@
"StorePath: ~a "StorePath: ~a
URL: nar/~a URL: nar/~a
Compression: none Compression: none
FileSize: ~a
NarHash: sha256:~a NarHash: sha256:~a
NarSize: ~d NarSize: ~d
References: ~a References: ~a~%"
FileSize: ~a~%"
%item %item
(basename %item) (basename %item)
(path-info-nar-size info)
(bytevector->nix-base32-string (bytevector->nix-base32-string
(path-info-hash info)) (path-info-hash info))
(path-info-nar-size info) (path-info-nar-size info)
(basename (first (path-info-references info))) (basename (first (path-info-references info)))))
(path-info-nar-size info)))
(signature (base64-encode (signature (base64-encode
(string->utf8 (string->utf8
(canonical-sexp->string (canonical-sexp->string
@ -170,15 +170,15 @@ FileSize: ~a~%"
"StorePath: ~a "StorePath: ~a
URL: nar/~a URL: nar/~a
Compression: none Compression: none
FileSize: ~a
NarHash: sha256:~a NarHash: sha256:~a
NarSize: ~d NarSize: ~d
References: ~%\ References: ~%"
FileSize: ~a~%"
item item
(uri-encode (basename item)) (uri-encode (basename item))
(path-info-nar-size info)
(bytevector->nix-base32-string (bytevector->nix-base32-string
(path-info-hash info)) (path-info-hash info))
(path-info-nar-size info)
(path-info-nar-size info))) (path-info-nar-size info)))
(signature (base64-encode (signature (base64-encode
(string->utf8 (string->utf8
@ -301,6 +301,35 @@ FileSize: ~a~%"
(list (assoc-ref info "Compression") (list (assoc-ref info "Compression")
(dirname (assoc-ref info "URL"))))) (dirname (assoc-ref info "URL")))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "/*.narinfo with lzip + gzip"
`((("StorePath" . ,%item)
("URL" . ,(string-append "nar/gzip/" (basename %item)))
("Compression" . "gzip")
("URL" . ,(string-append "nar/lzip/" (basename %item)))
("Compression" . "lzip"))
200
200)
(call-with-temporary-directory
(lambda (cache)
(let ((thread (with-separate-output-ports
(call-with-new-thread
(lambda ()
(guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
(wait-until-ready 6793)
(let* ((base "http://localhost:6793/")
(part (store-path-hash-part %item))
(url (string-append base part ".narinfo"))
(body (http-get-port url)))
(list (take (recutils->alist body) 5)
(response-code
(http-get (string-append base "nar/gzip/"
(basename %item))))
(response-code
(http-get (string-append base "nar/lzip/"
(basename %item))))))))))
(test-equal "custom nar path" (test-equal "custom nar path"
;; Serve nars at /foo/bar/chbouib instead of /nar. ;; Serve nars at /foo/bar/chbouib instead of /nar.
(list `(("StorePath" . ,%item) (list `(("StorePath" . ,%item)
@ -441,6 +470,52 @@ FileSize: ~a~%"
(stat:size (stat nar))) (stat:size (stat nar)))
(response-code uncompressed))))))))) (response-code uncompressed)))))))))
(unless (and (zlib-available?) (lzlib-available?))
(test-skip 1))
(test-equal "with cache, lzip + gzip"
'(200 200 404)
(call-with-temporary-directory
(lambda (cache)
(let ((thread (with-separate-output-ports
(call-with-new-thread
(lambda ()
(guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
(string-append "--cache=" cache)))))))
(wait-until-ready 6794)
(let* ((base "http://localhost:6794/")
(part (store-path-hash-part %item))
(url (string-append base part ".narinfo"))
(nar-url (cute string-append "nar/" <> "/"
(basename %item)))
(cached (cute string-append cache "/" <> "/"
(basename %item) ".narinfo"))
(nar (cute string-append cache "/" <> "/"
(basename %item) ".nar"))
(response (http-get url)))
(wait-for-file (cached "gzip"))
(let* ((body (http-get-port url))
(narinfo (recutils->alist body))
(uncompressed (string-append base "nar/"
(basename %item))))
(and (file-exists? (nar "gzip"))
(file-exists? (nar "lzip"))
(equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
`(("StorePath" . ,%item)
("URL" . ,(nar-url "gzip"))
("Compression" . "gzip")
("FileSize" . ,(number->string
(stat:size (stat (nar "gzip")))))
("URL" . ,(nar-url "lzip"))
("Compression" . "lzip")
("FileSize" . ,(number->string
(stat:size (stat (nar "lzip")))))))
(list (response-code
(http-get (string-append base (nar-url "gzip"))))
(response-code
(http-get (string-append base (nar-url "lzip"))))
(response-code
(http-get uncompressed))))))))))
(unless (zlib-available?) (unless (zlib-available?)
(test-skip 1)) (test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"