diff options
Diffstat (limited to 'guix/scripts/publish.scm')
| -rw-r--r-- | guix/scripts/publish.scm | 259 |
1 files changed, 241 insertions, 18 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index d8ac72f4ef..3faff061a7 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,13 +47,17 @@ #: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 @@ -70,6 +76,10 @@ Publish ~a over HTTP.\n") %store-directory) -C, --compression[=LEVEL] compress archives at LEVEL")) (display (_ " + -c, --cache=DIRECTORY cache published items to DIRECTORY")) + (display (_ " + --workers=N use N workers to bake items")) + (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " --nar-path=PATH use PATH as the prefix for nar URLs")) @@ -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 _ @@ -147,6 +164,13 @@ Publish ~a over HTTP.\n") %store-directory) (warning (_ "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))) @@ -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))) @@ -218,9 +245,7 @@ compression disabled~%")) 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." (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 @@ -303,6 +328,146 @@ 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)) + (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)) + (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) + 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 +499,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 +533,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 +660,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 +686,7 @@ blocking." (define* (make-request-handler store #:key + cache pool narinfo-ttl (nar-path "nar") (compression %no-compression)) @@ -504,14 +703,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 +736,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 +760,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) @@ -599,6 +814,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. @@ -624,6 +841,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: |