summaryrefslogtreecommitdiff
path: root/guix/scripts/publish.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/publish.scm')
-rw-r--r--guix/scripts/publish.scm357
1 files changed, 238 insertions, 119 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a236f3e45c..b4334b3f16 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -51,6 +51,7 @@
#:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file))
#:use-module (guix zlib)
+ #:autoload (guix lzlib) (lzlib-available?)
#:use-module (guix cache)
#:use-module (guix ui)
#:use-module (guix scripts)
@@ -74,8 +75,8 @@ Publish ~a over HTTP.\n") %store-directory)
(display (G_ "
-u, --user=USER change privileges to USER as soon as possible"))
(display (G_ "
- -C, --compression[=LEVEL]
- compress archives at LEVEL"))
+ -C, --compression[=METHOD:LEVEL]
+ compress archives with METHOD at LEVEL"))
(display (G_ "
-c, --cache=DIRECTORY cache published items to DIRECTORY"))
(display (G_ "
@@ -121,11 +122,14 @@ Publish ~a over HTTP.\n") %store-directory)
;; Since we compress on the fly, default to fast compression.
(compression 'gzip 3))
-(define (actual-compression item requested)
- "Return the actual compression used for ITEM, which may be %NO-COMPRESSION
+(define (default-compression type)
+ (compression type 3))
+
+(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
@@ -153,18 +157,28 @@ if ITEM is already compressed."
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
- (if (zlib-available?)
- (alist-cons 'compression
- (compression 'gzip level)
- result)
- (begin
- (warning (G_ "zlib support is missing; \
-compression disabled~%"))
- result))))))
+ (let* ((colon (string-index arg #\:))
+ (type (cond
+ (colon (string-take arg colon))
+ ((string->number arg) "gzip")
+ (else arg)))
+ (level (if colon
+ (string->number*
+ (string-drop arg (+ 1 colon)))
+ (or (string->number arg) 3))))
+ (match level
+ (0
+ (alist-cons 'compression %no-compression result))
+ (level
+ (match (string->compression-type type)
+ ((? symbol? type)
+ (alist-cons 'compression
+ (compression type level)
+ result))
+ (_
+ (warning (G_ "~a: unsupported compression type~%")
+ type)
+ result)))))))
(option '(#\c "cache") #t #f
(lambda (opt name arg result)
(alist-cons 'cache arg result)))
@@ -203,11 +217,6 @@ compression disabled~%"))
(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))
@@ -235,29 +244,40 @@ compression disabled~%"))
(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))
" "))
@@ -265,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)
@@ -318,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
@@ -334,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
@@ -350,6 +374,9 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
"/" (basename item)
".narinfo"))
+(define (hash-part-mapping-cache-file directory hash)
+ (string-append directory "/hashes/" hash))
+
(define run-single-baker
(let ((baking (make-weak-value-hash-table))
(mutex (make-mutex)))
@@ -403,8 +430,29 @@ items. Failing that, we could eventually have to recompute them and return
+inf.0
(expiration-time file))))))
+(define (hash-part->path* store hash cache)
+ "Like 'hash-part->path' but cached results under CACHE. This ensures we can
+still map HASH to the corresponding store file name, even if said store item
+vanished from the store in the meantime."
+ (let ((cached (hash-part-mapping-cache-file cache hash)))
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file cached read-string))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (match (hash-part->path store hash)
+ ("" "")
+ (result
+ (mkdir-p (dirname cached))
+ (call-with-output-file (string-append cached ".tmp")
+ (lambda (port)
+ (display result port)))
+ (rename-file (string-append cached ".tmp") cached)
+ result))
+ (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
@@ -412,17 +460,22 @@ CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
requested using POOL."
(define (delete-entry narinfo)
;; Delete NARINFO and the corresponding nar from CACHE.
- (let ((nar (string-append (string-drop-right narinfo
- (string-length ".narinfo"))
- ".nar")))
+ (let* ((nar (string-append (string-drop-right narinfo
+ (string-length ".narinfo"))
+ ".nar"))
+ (base (basename narinfo ".narinfo"))
+ (hash (string-take base (string-index base #\-)))
+ (mapping (hash-part-mapping-cache-file cache hash)))
(delete-file* narinfo)
- (delete-file* nar)))
-
- (let* ((item (hash-part->path store hash))
- (compression (actual-compression item compression))
- (cached (and (not (string-null? item))
- (narinfo-cache-file cache item
- #:compression compression))))
+ (delete-file* nar)
+ (delete-file* mapping)))
+
+ (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)
@@ -446,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
@@ -463,47 +516,75 @@ requested using POOL."
(else
(not-found request #:phrase "")))))
+(define (compress-nar cache item compression)
+ "Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
+ (define nar
+ (nar-cache-file cache item #:compression compression))
+
+ (mkdir-p (dirname nar))
+ (match (compression-type compression)
+ ('gzip
+ ;; Note: the file port gets closed along with the gzip port.
+ (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
+ (lambda (port)
+ (write-file item port))
+ #:level (compression-level compression)
+ #:buffer-size (* 128 1024))
+ (rename-file (string-append nar ".tmp") nar))
+ ('lzip
+ ;; Note: the file port gets closed along with the lzip port.
+ (call-with-lzip-output-port (open-output-file (string-append nar ".tmp"))
+ (lambda (port)
+ (write-file item port))
+ #:level (compression-level compression))
+ (rename-file (string-append nar ".tmp") nar))
+ ('none
+ ;; Cache nars even when compression is disabled so that we can
+ ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
+ (with-atomic-file-output nar
+ (lambda (port)
+ (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)))
-
- (mkdir-p (dirname nar))
- (match (compression-type compression)
- ('gzip
- ;; Note: the file port gets closed along with the gzip port.
- (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
- (lambda (port)
- (write-file item port))
- #:level (compression-level compression)
- #:buffer-size (* 128 1024))
- (rename-file (string-append nar ".tmp") nar))
- ('none
- ;; Cache nars even when compression is disabled so that we can
- ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
- (with-atomic-file-output nar
- (lambda (port)
- (write-file item port)))))
-
- (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))))))
+ (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)))))
+
+ (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
@@ -687,6 +768,9 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
(make-gzip-output-port (response-port response)
#:level level
#:buffer-size (* 64 1024)))
+ (($ <compression> 'lzip level)
+ (make-lzip-output-port (response-port response)
+ #:level level))
(($ <compression> 'none)
(response-port response))
(#f
@@ -761,12 +845,33 @@ blocking."
http-write
(@@ (web server http) http-close))
+(define (string->compression-type string)
+ "Return a symbol denoting the compression method expressed by STRING; return
+#f if STRING doesn't match any supported method."
+ (match string
+ ("gzip" (and (zlib-available?) 'gzip))
+ ("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)
+
(define nar-path?
(let ((expected (split-and-decode-uri-path nar-path)))
(cut equal? expected <>)))
@@ -785,19 +890,17 @@ blocking."
(render-home-page request))
;; /<hash>.narinfo
(((= extract-narinfo-hash (? string? hash)))
- ;; TODO: Register roots for HASH that will somehow remain for
- ;; NARINFO-TTL.
(if cache
(render-narinfo/cached store request hash
#:cache cache
#: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)
@@ -815,13 +918,11 @@ blocking."
;; is restarted with different compression parameters.
;; /nar/gzip/<store-item>
- ((components ... "gzip" store-item)
- (if (and (nar-path? components) (zlib-available?))
- (let ((compression (match compression
- (($ <compression> 'gzip)
- compression)
- (_
- %default-gzip-compression))))
+ ((components ... (? compression-type? type) store-item)
+ (if (nar-path? components)
+ (let* ((compression-type (string->compression-type type))
+ (compression (effective-compression compression-type
+ compressions)))
(if cache
(render-nar/cached store cache request store-item
#:ttl narinfo-ttl
@@ -845,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
@@ -853,7 +955,7 @@ blocking."
#:pool pool
#:nar-path nar-path
#:narinfo-ttl narinfo-ttl
- #:compression compression)
+ #:compressions compressions)
concurrent-http-server
`(#:socket ,socket)))
@@ -892,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)
@@ -919,10 +1031,17 @@ consider using the '--user' option!~%")))
(parameterize ((%public-key public-key)
(%private-key private-key))
- (format #t (G_ "publishing ~a on ~a, port ~d~%")
- %store-directory
- (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
- (sockaddr:port address))
+ (info (G_ "publishing ~a on ~a, port ~d~%")
+ %store-directory
+ (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+ (sockaddr:port address))
+
+ (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)))
@@ -936,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:
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-10 08:26:12 +0000