me/guix
Archived
1
0
Fork 0
Code Activity

publish: '--compression' can be repeated.

Browse source 
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
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}
@itemx -c @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)
(compression type 3))
(define (actual-compression item requested)
"Return the actual compression used for ITEM, which may be %NO-COMPRESSION
(define (actual-compressions item requested)
"Return the actual compressions used for ITEM, which may be %NO-COMPRESSION
if ITEM is already compressed."
(if (compressed-file? item)
%no-compression
(list %no-compression)
requested))
(define %options
@ -217,11 +217,6 @@ if ITEM is already compressed."
(public-key-file . ,%public-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.
(workers . ,(current-processor-count))
@ -249,29 +244,40 @@ if ITEM is already compressed."
(define base64-encode-string
(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
#:key (compression %no-compression)
(nar-path "nar") file-size)
#: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-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))
(compression (actual-compression store-path compression))
(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))))
(compressions (actual-compressions store-path compressions))
(hash (bytevector->nix-base32-string
(path-info-hash path-info)))
(size (path-info-nar-size path-info))
(file-size (or file-size
(and (eq? compression %no-compression) size)))
(file-sizes `((,%no-compression . ,size) ,@file-sizes))
(references (string-join
(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
"\
StorePath: ~a
URL: ~a
Compression: ~a
~{~a~}\
NarHash: sha256:~a
NarSize: ~d
References: ~a~%~a"
store-path url
(compression-type compression)
hash size references
(if file-size
(format #f "FileSize: ~a~%" file-size)
"")))
References: ~a~%"
store-path
(map (lambda (compression)
(let ((size (assoc-ref file-sizes
compression)))
(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
;; info for a derivation.
(info (if (not deriver)
@ -332,7 +342,7 @@ References: ~a~%~a"
%nix-cache-info))))
(define* (render-narinfo store request hash
#:key ttl (compression %no-compression)
#:key ttl (compressions (list %no-compression))
(nar-path "nar"))
"Render metadata for the store path corresponding to HASH. If TTL is true,
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
(narinfo-string store store-path (%private-key)
#:nar-path nar-path
#:compression compression)
#:compressions compressions)
<>)))))
(define* (nar-cache-file directory item
@ -442,7 +452,7 @@ vanished from the store in the meantime."
(apply throw args))))))
(define* (render-narinfo/cached store request hash
#:key ttl (compression %no-compression)
#:key ttl (compressions (list %no-compression))
(nar-path "nar")
cache pool)
"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* mapping)))
(let* ((item (hash-part->path* store hash cache))
(compression (actual-compression item compression))
(cached (and (not (string-null? item))
(narinfo-cache-file cache item
#:compression compression))))
(let* ((item (hash-part->path* store hash cache))
(compressions (actual-compressions item compressions))
(cached (and (not (string-null? item))
(narinfo-cache-file cache item
#:compression
(first compressions)))))
(cond ((string-null? item)
(not-found request))
((file-exists? cached)
@ -488,7 +499,7 @@ requested using POOL."
;; (format #t "baking ~s~%" item)
(bake-narinfo+nar cache item
#:ttl ttl
#:compression compression
#:compressions compressions
#:nar-path nar-path)))
(when ttl
@ -535,30 +546,45 @@ requested using POOL."
(write-file item port))))))
(define* (bake-narinfo+nar cache item
#:key ttl (compression %no-compression)
#:key ttl (compressions (list %no-compression))
(nar-path "/nar"))
"Write the narinfo and nar for ITEM to CACHE."
(let* ((compression (actual-compression item compression))
(nar (nar-cache-file cache item
#:compression compression))
(narinfo (narinfo-cache-file cache item
#:compression compression)))
(compress-nar cache item compression)
(define (compressed-nar-size compression)
(let* ((nar (nar-cache-file cache item #:compression compression))
(stat (stat nar #f)))
(and stat
(cons compression (stat:size stat)))))
(mkdir-p (dirname narinfo))
(with-atomic-file-output narinfo
(lambda (port)
;; Open a new connection to the store. We cannot reuse the main
;; thread's connection to the store since we would end up sending
;; stuff concurrently on the same channel.
(with-store store
(display (narinfo-string store item
(%private-key)
#:nar-path nar-path
#:compression compression
#:file-size (and=> (stat nar #f)
stat:size))
port))))))
(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
(lambda (port)
;; Open a new connection to the store. We cannot reuse the main
;; thread's connection to the store since we would end up sending
;; stuff concurrently on the same channel.
(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
;; internal consumption: it allows us to pass the compression info to
@ -827,12 +853,22 @@ blocking."
("lzip" (and (lzlib-available?) 'lzip))
(_ #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
#:key
cache pool
narinfo-ttl
(nar-path "nar")
(compression %no-compression))
(compressions (list %no-compression)))
(define compression-type?
string->compression-type)
@ -860,11 +896,11 @@ blocking."
#:pool pool
#:ttl narinfo-ttl
#:nar-path nar-path
#:compression compression)
#:compressions compressions)
(render-narinfo store request hash
#:ttl narinfo-ttl
#:nar-path nar-path
#:compression compression)))
#:compressions compressions)))
;; /nar/file/NAME/sha256/HASH
(("file" name "sha256" hash)
(guard (c ((invalid-base32-character? c)
@ -885,15 +921,8 @@ blocking."
((components ... (? compression-type? type) store-item)
(if (nar-path? components)
(let* ((compression-type (string->compression-type type))
(compression (match compression
(($ <compression> type)
(if (eq? type compression-type)
compression
(default-compression
compression-type)))
(_
(default-compression
compression-type)))))
(compression (effective-compression compression-type
compressions)))
(if cache
(render-nar/cached store cache request store-item
#:ttl narinfo-ttl
@ -917,7 +946,8 @@ blocking."
(not-found request))))
(define* (run-publish-server socket store
#:key (compression %no-compression)
#:key
(compressions (list %no-compression))
(nar-path "nar") narinfo-ttl
cache pool)
(run-server (make-request-handler store
@ -925,7 +955,7 @@ blocking."
#:pool pool
#:nar-path nar-path
#:narinfo-ttl narinfo-ttl
#:compression compression)
#:compressions compressions)
concurrent-http-server
`(#:socket ,socket)))
@ -964,7 +994,17 @@ blocking."
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
(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)))
(make-socket-address (sockaddr:fam addr)
(sockaddr:addr addr)
@ -996,9 +1036,11 @@ consider using the '--user' option!~%")))
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
(sockaddr:port address))
(when compression
(info (G_ "using '~a' compression method, level ~a~%")
(compression-type compression) (compression-level compression)))
(for-each (lambda (compression)
(info (G_ "using '~a' compression method, level ~a~%")
(compression-type compression)
(compression-level compression)))
compressions)
(when repl-port
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
@ -1013,7 +1055,7 @@ consider using the '--user' option!~%")))
#:thread-name
"publish worker"))
#:nar-path nar-path
#:compression compression
#:compressions compressions
#:narinfo-ttl ttl))))))
;;; Local Variables:

89
tests/publish.scm
View file

@ -138,17 +138,17 @@
"StorePath: ~a
URL: nar/~a
Compression: none
FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~a
FileSize: ~a~%"
References: ~a~%"
%item
(basename %item)
(path-info-nar-size info)
(bytevector->nix-base32-string
(path-info-hash info))
(path-info-nar-size info)
(basename (first (path-info-references info)))
(path-info-nar-size info)))
(basename (first (path-info-references info)))))
(signature (base64-encode
(string->utf8
(canonical-sexp->string
@ -170,15 +170,15 @@ FileSize: ~a~%"
"StorePath: ~a
URL: nar/~a
Compression: none
FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~%\
FileSize: ~a~%"
References: ~%"
item
(uri-encode (basename item))
(path-info-nar-size info)
(bytevector->nix-base32-string
(path-info-hash info))
(path-info-nar-size info)
(path-info-nar-size info)))
(signature (base64-encode
(string->utf8
@ -301,6 +301,35 @@ FileSize: ~a~%"
(list (assoc-ref info "Compression")
(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"
;; Serve nars at /foo/bar/chbouib instead of /nar.
(list `(("StorePath" . ,%item)
@ -441,6 +470,52 @@ FileSize: ~a~%"
(stat:size (stat nar)))
(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?)
(test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"