@@ -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}
@@ -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:
@@ -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"
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. --- doc/guix.texi | 5 + guix/scripts/publish.scm | 204 +++++++++++++++++++++++---------------- tests/publish.scm | 89 +++++++++++++++-- 3 files changed, 210 insertions(+), 88 deletions(-)