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.
master
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}

204
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* (store-item->recutils store-item
#:key
(nar-path "nar")
(compression %no-compression)
file-size)
"Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM,
with COMPRESSION, starting at NAR-PATH."
(let ((url (encode-and-join-uri-path
`(,@(split-and-decode-uri-path nar-path)
,@(match compression
(($ <compression> 'none)
'())
(($ <compression> type)
(list (symbol->string type))))
,(basename store-item)))))
(format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]"
url (compression-type compression) file-size)))
(define* (narinfo-string store store-path key (define* (narinfo-string store store-path key
#:key (compression %no-compression) #:key (compressions (list %no-compression))
(nar-path "nar") file-size) (nar-path "nar") (file-sizes '()))
"Generate a narinfo key/value string for STORE-PATH; an exception is raised "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 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. narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs.
Optionally, FILE-SIZE can specify the size in bytes of the compressed NAR; it
informs the client of how much needs to be downloaded." 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)) (let* ((path-info (query-path-info store store-path))
(compression (actual-compression store-path compression)) (compressions (actual-compressions store-path compressions))
(url (encode-and-join-uri-path
`(,@(split-and-decode-uri-path nar-path)
,@(match compression
(($ <compression> 'none)
'())
(($ <compression> type)
(list (symbol->string type))))
,(basename store-path))))
(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
@ -460,11 +470,12 @@ requested using POOL."
(delete-file* nar) (delete-file* nar)
(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)))
(with-atomic-file-output narinfo
(lambda (port) (for-each (cut compress-nar cache item <>) compressions)
;; Open a new connection to the store. We cannot reuse the main
;; thread's connection to the store since we would end up sending (match compressions
;; stuff concurrently on the same channel. ((main others ...)
(with-store store (let ((narinfo (narinfo-cache-file cache item
(display (narinfo-string store item #:compression main)))
(%private-key) (with-atomic-file-output narinfo
#:nar-path nar-path (lambda (port)
#:compression compression ;; Open a new connection to the store. We cannot reuse the main
#:file-size (and=> (stat nar #f) ;; thread's connection to the store since we would end up sending
stat:size)) ;; stuff concurrently on the same channel.
port)))))) (with-store store
(let ((sizes (filter-map compressed-nar-size compression)))
(display (narinfo-string store item
(%private-key)
#:nar-path nar-path
#:compressions compressions
#:file-sizes sizes)
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"