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.scm332
1 files changed, 286 insertions, 46 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index d8ac72f4ef..db7f6a957e 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -24,6 +24,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
@@ -38,6 +39,7 @@
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
+ #:autoload (sxml simple) (sxml->xml)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix config)
@@ -45,44 +47,52 @@
#:use-module (guix hash)
#:use-module (guix pki)
#:use-module (guix pk-crypto)
+ #:use-module (guix workers)
#:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file))
#:use-module (guix zlib)
+ #:use-module (guix cache)
#:use-module (guix ui)
#:use-module (guix scripts)
- #:use-module ((guix utils) #:select (compressed-file?))
- #:use-module ((guix build utils) #:select (dump-port))
+ #:use-module ((guix utils)
+ #:select (with-atomic-file-output compressed-file?))
+ #:use-module ((guix build utils)
+ #:select (dump-port mkdir-p find-files))
#:export (%public-key
%private-key
guix-publish))
(define (show-help)
- (format #t (_ "Usage: guix publish [OPTION]...
+ (format #t (G_ "Usage: guix publish [OPTION]...
Publish ~a over HTTP.\n") %store-directory)
- (display (_ "
+ (display (G_ "
-p, --port=PORT listen on PORT"))
- (display (_ "
+ (display (G_ "
--listen=HOST listen on the network interface for HOST"))
- (display (_ "
+ (display (G_ "
-u, --user=USER change privileges to USER as soon as possible"))
- (display (_ "
+ (display (G_ "
-C, --compression[=LEVEL]
compress archives at LEVEL"))
- (display (_ "
+ (display (G_ "
+ -c, --cache=DIRECTORY cache published items to DIRECTORY"))
+ (display (G_ "
+ --workers=N use N workers to bake items"))
+ (display (G_ "
--ttl=TTL announce narinfos can be cached for TTL seconds"))
- (display (_ "
+ (display (G_ "
--nar-path=PATH use PATH as the prefix for nar URLs"))
- (display (_ "
+ (display (G_ "
--public-key=FILE use FILE as the public key for signatures"))
- (display (_ "
+ (display (G_ "
--private-key=FILE use FILE as the private key for signatures"))
- (display (_ "
+ (display (G_ "
-r, --repl[=PORT] spawn REPL server on PORT"))
(newline)
- (display (_ "
+ (display (G_ "
-h, --help display this help and exit"))
- (display (_ "
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
@@ -93,7 +103,7 @@ Publish ~a over HTTP.\n") %store-directory)
(lambda ()
(getaddrinfo host))
(lambda (key error)
- (leave (_ "lookup of host '~a' failed: ~a~%")
+ (leave (G_ "lookup of host '~a' failed: ~a~%")
host (gai-strerror error)))))
;; Nar compression parameters.
@@ -110,6 +120,13 @@ 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
+if ITEM is already compressed."
+ (if (compressed-file? item)
+ %no-compression
+ requested))
+
(define %options
(list (option '(#\h "help") #f #f
(lambda _
@@ -131,7 +148,7 @@ Publish ~a over HTTP.\n") %store-directory)
(alist-cons 'address (addrinfo:addr info)
result))
(()
- (leave (_ "lookup of host '~a' returned nothing")
+ (leave (G_ "lookup of host '~a' returned nothing")
name)))))
(option '(#\C "compression") #f #t
(lambda (opt name arg result)
@@ -144,14 +161,21 @@ Publish ~a over HTTP.\n") %store-directory)
(compression 'gzip level)
result)
(begin
- (warning (_ "zlib support is missing; \
+ (warning (G_ "zlib support is missing; \
compression disabled~%"))
result))))))
+ (option '(#\c "cache") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cache arg result)))
+ (option '("workers") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'workers (string->number* arg)
+ result)))
(option '("ttl") #t #f
(lambda (opt name arg result)
(let ((duration (string->duration arg)))
(unless duration
- (leave (_ "~a: invalid duration~%") arg))
+ (leave (G_ "~a: invalid duration~%") arg))
(alist-cons 'narinfo-ttl (time-second duration)
result))))
(option '("nar-path") #t #f
@@ -183,6 +207,9 @@ compression disabled~%"))
%default-gzip-compression
%no-compression))
+ ;; Default number of workers when caching is enabled.
+ (workers . ,(current-processor-count))
+
(address . ,(make-socket-address AF_INET INADDR_ANY 0))
(repl . #f)))
@@ -213,14 +240,14 @@ compression disabled~%"))
(define* (narinfo-string store store-path key
#:key (compression %no-compression)
- (nar-path "nar"))
+ (nar-path "nar") file-size)
"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."
+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."
(let* ((path-info (query-path-info store store-path))
- (compression (if (compressed-file? store-path)
- %no-compression
- compression))
+ (compression (actual-compression store-path compression))
(url (encode-and-join-uri-path
`(,@(split-and-decode-uri-path nar-path)
,@(match compression
@@ -232,6 +259,8 @@ narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs."
(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)))
(references (string-join
(map basename (path-info-references path-info))
" "))
@@ -243,10 +272,13 @@ URL: ~a
Compression: ~a
NarHash: sha256:~a
NarSize: ~d
-References: ~a~%"
+References: ~a~%~a"
store-path url
(compression-type compression)
- hash size references))
+ hash size references
+ (if file-size
+ (format #f "FileSize: ~a~%" file-size)
+ "")))
;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation.
(info (if (not deriver)
@@ -268,10 +300,15 @@ References: ~a~%"
(canonical-sexp->string (signed-string info)))))
(format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
-(define (not-found request)
+(define* (not-found request
+ #:key (phrase "Resource not found")
+ ttl)
"Render 404 response for REQUEST."
- (values (build-response #:code 404)
- (string-append "Resource not found: "
+ (values (build-response #:code 404
+ #:headers (if ttl
+ `((cache-control (max-age . ,ttl)))
+ '()))
+ (string-append phrase ": "
(uri-path (request-uri request)))))
(define (render-nix-cache-info)
@@ -303,6 +340,151 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
#:compression compression)
<>)))))
+(define* (nar-cache-file directory item
+ #:key (compression %no-compression))
+ (string-append directory "/"
+ (symbol->string (compression-type compression))
+ "/" (basename item) ".nar"))
+
+(define* (narinfo-cache-file directory item
+ #:key (compression %no-compression))
+ (string-append directory "/"
+ (symbol->string (compression-type compression))
+ "/" (basename item)
+ ".narinfo"))
+
+(define run-single-baker
+ (let ((baking (make-weak-value-hash-table))
+ (mutex (make-mutex)))
+ (lambda (item thunk)
+ "Run THUNK, which is supposed to bake ITEM, but make sure only one
+thread is baking ITEM at a given time."
+ (define selected?
+ (with-mutex mutex
+ (and (not (hash-ref baking item))
+ (begin
+ (hash-set! baking item (current-thread))
+ #t))))
+
+ (when selected?
+ (dynamic-wind
+ (const #t)
+ thunk
+ (lambda ()
+ (with-mutex mutex
+ (hash-remove! baking item))))))))
+
+(define-syntax-rule (single-baker item exp ...)
+ "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM
+at a time."
+ (run-single-baker item (lambda () exp ...)))
+
+
+(define (narinfo-files cache)
+ "Return the list of .narinfo files under CACHE."
+ (if (file-is-directory? cache)
+ (find-files cache
+ (lambda (file stat)
+ (string-suffix? ".narinfo" file)))
+ '()))
+
+(define* (render-narinfo/cached store request hash
+ #:key ttl (compression %no-compression)
+ (nar-path "nar")
+ cache pool)
+ "Respond to the narinfo request for REQUEST. If the narinfo is available in
+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")))
+ (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))))
+ (cond ((string-null? item)
+ (not-found request))
+ ((file-exists? cached)
+ ;; Narinfo is in cache, send it.
+ (values `((content-type . (application/x-nix-narinfo))
+ ,@(if ttl
+ `((cache-control (max-age . ,ttl)))
+ '()))
+ (lambda (port)
+ (display (call-with-input-file cached
+ read-string)
+ port))))
+ ((valid-path? store item)
+ ;; Nothing in cache: bake the narinfo and nar in the background and
+ ;; return 404.
+ (eventually pool
+ (single-baker item
+ ;; (format #t "baking ~s~%" item)
+ (bake-narinfo+nar cache item
+ #:ttl ttl
+ #:compression compression
+ #:nar-path nar-path))
+
+ (when ttl
+ (single-baker 'cache-cleanup
+ (maybe-remove-expired-cache-entries cache
+ narinfo-files
+ #:entry-expiration
+ (file-expiration-time ttl)
+ #:delete-entry delete-entry
+ #:cleanup-period ttl))))
+ (not-found request
+ #:phrase "We're baking it"
+ #:ttl 300)) ;should be available within 5m
+ (else
+ (not-found request)))))
+
+(define* (bake-narinfo+nar cache item
+ #:key ttl (compression %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
+ ;; When compression is disabled, we retrieve files directly from the
+ ;; store; no need to cache them.
+ #t))
+
+ (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))))))
+
;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
;; internal consumption: it allows us to pass the compression info to
;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
@@ -334,6 +516,21 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
store-path)
(not-found request))))
+(define* (render-nar/cached store cache request store-item
+ #:key (compression %no-compression))
+ "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE,
+return it; otherwise, return 404."
+ (let ((cached (nar-cache-file cache store-item
+ #:compression compression)))
+ (if (file-exists? cached)
+ (values `((content-type . (application/octet-stream
+ (charset . "ISO-8859-1"))))
+ ;; XXX: We're not returning the actual contents, deferring
+ ;; instead to 'http-write'. This is a hack to work around
+ ;; <http://bugs.gnu.org/21093>.
+ cached)
+ (not-found request))))
+
(define (render-content-addressed-file store request
name algo hash)
"Return the content of the result of the fixed-output derivation NAME that
@@ -353,6 +550,22 @@ has the given HASH of type ALGO."
(not-found request)))
(not-found request)))
+(define (render-home-page request)
+ "Render the home page."
+ (values `((content-type . (text/html (charset . "UTF-8"))))
+ (call-with-output-string
+ (lambda (port)
+ (sxml->xml '(html
+ (head (title "GNU Guix Substitute Server"))
+ (body
+ (h1 "GNU Guix Substitute Server")
+ (p "Hi, "
+ (a (@ (href
+ "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html"))
+ (tt "guix publish"))
+ " speaking. Welcome!")))
+ port)))))
+
(define extract-narinfo-hash
(let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
(lambda (str)
@@ -464,7 +677,9 @@ blocking."
size)
client))
(output (response-port response)))
- (dump-port input output)
+ (if (file-port? output)
+ (sendfile output input size)
+ (dump-port input output))
(close-port output)
(values)))))
(lambda args
@@ -488,6 +703,7 @@ blocking."
(define* (make-request-handler store
#:key
+ cache pool
narinfo-ttl
(nar-path "nar")
(compression %no-compression))
@@ -504,14 +720,24 @@ blocking."
;; /nix-cache-info
(("nix-cache-info")
(render-nix-cache-info))
+ ;; /
+ ((or () ("index.html"))
+ (render-home-page request))
;; /<hash>.narinfo
(((= extract-narinfo-hash (? string? hash)))
;; TODO: Register roots for HASH that will somehow remain for
;; NARINFO-TTL.
- (render-narinfo store request hash
- #:ttl narinfo-ttl
- #:nar-path nar-path
- #:compression compression))
+ (if cache
+ (render-narinfo/cached store request hash
+ #:cache cache
+ #:pool pool
+ #:ttl narinfo-ttl
+ #:nar-path nar-path
+ #:compression compression)
+ (render-narinfo store request hash
+ #:ttl narinfo-ttl
+ #:nar-path nar-path
+ #:compression compression)))
;; /nar/file/NAME/sha256/HASH
(("file" name "sha256" hash)
(guard (c ((invalid-base32-character? c)
@@ -527,13 +753,16 @@ blocking."
;; /nar/gzip/<store-item>
((components ... "gzip" store-item)
(if (and (nar-path? components) (zlib-available?))
- (render-nar store request store-item
- #:compression
- (match compression
- (($ <compression> 'gzip)
- compression)
- (_
- %default-gzip-compression)))
+ (let ((compression (match compression
+ (($ <compression> 'gzip)
+ compression)
+ (_
+ %default-gzip-compression))))
+ (if cache
+ (render-nar/cached store cache request store-item
+ #:compression compression)
+ (render-nar store request store-item
+ #:compression compression)))
(not-found request)))
;; /nar/<store-item>
@@ -548,8 +777,11 @@ blocking."
(define* (run-publish-server socket store
#:key (compression %no-compression)
- (nar-path "nar") narinfo-ttl)
+ (nar-path "nar") narinfo-ttl
+ cache pool)
(run-server (make-request-handler store
+ #:cache cache
+ #:pool pool
#:nar-path nar-path
#:narinfo-ttl narinfo-ttl
#:compression compression)
@@ -572,7 +804,7 @@ blocking."
(setgid (passwd:gid user))
(setuid (passwd:uid user))))
(lambda (key proc message args . rest)
- (leave (_ "user '~a' not found: ~a~%")
+ (leave (G_ "user '~a' not found: ~a~%")
user (apply format #f message args)))))
@@ -584,9 +816,9 @@ blocking."
(with-error-handling
(let* ((opts (args-fold* args %options
(lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
+ (leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
- (leave (_ "~A: extraneous argument~%") arg))
+ (leave (G_ "~A: extraneous argument~%") arg))
%default-options))
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
@@ -599,6 +831,8 @@ blocking."
(socket (open-server-socket address))
(nar-path (assoc-ref opts 'nar-path))
(repl-port (assoc-ref opts 'repl))
+ (cache (assoc-ref opts 'cache))
+ (workers (assoc-ref opts 'workers))
;; Read the key right away so that (1) we fail early on if we can't
;; access them, and (2) we can then drop privileges.
@@ -611,12 +845,12 @@ blocking."
(gather-user-privileges user))
(when (zero? (getuid))
- (warning (_ "server running as root; \
+ (warning (G_ "server running as root; \
consider using the '--user' option!~%")))
(parameterize ((%public-key public-key)
(%private-key private-key))
- (format #t (_ "publishing ~a on ~a, port ~d~%")
+ (format #t (G_ "publishing ~a on ~a, port ~d~%")
%store-directory
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
(sockaddr:port address))
@@ -624,6 +858,12 @@ consider using the '--user' option!~%")))
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
(with-store store
(run-publish-server socket store
+ #:cache cache
+ #:pool (and cache (make-pool workers))
#:nar-path nar-path
#:compression compression
#:narinfo-ttl ttl))))))
+
+;;; Local Variables:
+;;; eval: (put 'single-baker 'scheme-indent-function 1)
+;;; End:
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-18 21:25:26 +0000