[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: DRAFT publish: Add '--cache' and '--workers'.
From: |
Ludovic Courtès |
Subject: |
03/03: DRAFT publish: Add '--cache' and '--workers'. |
Date: |
Mon, 17 Apr 2017 17:32:45 -0400 (EDT) |
civodul pushed a commit to branch wip-publish-baking
in repository guix.
commit 4a2557d7f4fc91234eeff3e72452af414b3f1c4a
Author: Ludovic Courtès <address@hidden>
Date: Mon Apr 17 23:13:40 2017 +0200
DRAFT publish: Add '--cache' and '--workers'.
These options allow nars to be "baked" off-line and cached instead of
being compressed on the fly. As a side-effect, this allows us to
provide a 'Content-Length' header for nars.
* guix/scripts/publish.scm (show-help, %options): Add '--cache' and
'--workers'.
(%default-options): Add 'workers'.
(nar-cache-file, narinfo-cache-file, run-single-baker): New procedures.
(single-baker): New macro.
(render-narinfo/cached, bake-narinfo+nar)
(render-nar/cached): New procedures.
(make-request-handler): Add #:cache and #:pool parameters and honor
them.
(run-publish-server): Likewise.
(guix-publish): Honor '--cache' and '--workers'.
---
guix/scripts/publish.scm | 189 +++++++++++++++++++++++++++++++++++++++++++----
1 file changed, 175 insertions(+), 14 deletions(-)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 111cb29..556b6ed 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)
@@ -45,13 +46,15 @@
#: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 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))
#:export (%public-key
%private-key
@@ -70,6 +73,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"))
@@ -154,6 +161,13 @@ if ITEM is already compressed."
(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)))
@@ -190,6 +204,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)))
@@ -308,6 +325,117 @@ 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* (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."
+ (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 store cache item
+ #:ttl ttl
+ #:compression compression
+ #:nar-path nar-path)))
+ (not-found request))
+ (else
+ (not-found request)))))
+
+(define* (bake-narinfo+nar store 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)
+ (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>.
@@ -339,6 +467,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
@@ -493,6 +636,7 @@ blocking."
(define* (make-request-handler store
#:key
+ cache pool
narinfo-ttl
(nar-path "nar")
(compression %no-compression))
@@ -513,10 +657,17 @@ blocking."
(((= 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)
@@ -532,13 +683,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>
@@ -553,8 +707,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)
@@ -604,6 +761,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.
@@ -629,6 +788,8 @@ 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))))))