aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am1
-rw-r--r--nar-herder/cached-compression.scm356
-rw-r--r--nar-herder/database.scm246
-rw-r--r--nar-herder/server.scm121
-rw-r--r--scripts/nar-herder.in97
5 files changed, 782 insertions, 39 deletions
diff --git a/Makefile.am b/Makefile.am
index 7ac77d7..d2617ab 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -7,6 +7,7 @@ SOURCES = \
nar-herder/database.scm \
nar-herder/server.scm \
nar-herder/recent-changes.scm \
+ nar-herder/cached-compression.scm \
nar-herder/storage.scm \
nar-herder/mirror.scm \
nar-herder/utils.scm
diff --git a/nar-herder/cached-compression.scm b/nar-herder/cached-compression.scm
new file mode 100644
index 0000000..1537169
--- /dev/null
+++ b/nar-herder/cached-compression.scm
@@ -0,0 +1,356 @@
+;;; Nar Herder
+;;;
+;;; Copyright © 2022, 2023 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (nar-herder cached-compression)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 atomic)
+ #:use-module (ice-9 threads)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module ((guix build utils)
+ #:select (dump-port mkdir-p))
+ #:use-module (nar-herder utils)
+ #:use-module (nar-herder database)
+ #:export (make-maybe-trigger-creation-of-compressed-nars))
+
+;; Nar caching overview
+;;
+;; On start
+;; - Compute the size of each cached compression directory
+;; - Remove database entries if they're missing from the directory
+;; - Remove files if they're missing from the database
+;; - Remove (random TODO) files if the size exceeds the max
+;;
+;; On nar usage
+;; - Bump count
+;; - If count is sufficient
+;; - Trigger generation of the cached nar
+;; - Skip if the work queue already includes this job
+;; - At the start of the job, check for a database entry and exit
+;; early if one exists
+;; - Update the size of the cached compression directory
+;; - If the size exceeds the max, remove (random TODO) files
+
+(define (perform-cached-compression-startup database
+ enabled-cached-compressions)
+ (let* ((database-entries-missing-files
+ ;; List tracking entries in the database for cached files,
+ ;; where the file is missing from the disk.
+ ;;
+ ;; These database entries will be removed at the end of the
+ ;; startup procecss.
+ '())
+
+ ;; alist of compression to hash table of files
+ ;;
+ ;; Entries from the hash tables will be removed when the
+ ;; database entry is processed below, so these hash tables
+ ;; will be left reflecting files in the directories, but with
+ ;; no entry in the database.
+ ;;
+ ;; These files will be deleted at the end of the startup
+ ;; process.
+ (files-by-compression
+ (map
+ (match-lambda
+ ((compression . details)
+ (let ((result (make-hash-table)))
+ (for-each
+ (lambda (file)
+ (hash-set! result file #t))
+ (scandir (assq-ref details 'directory)
+ (negate (cut member <> '("." "..")))))
+ (cons compression
+ result))))
+ enabled-cached-compressions))
+
+ (cached-bytes-by-compression
+ (database-fold-cached-narinfo-files
+ database
+ (lambda (details result)
+ (let ((compression
+ (assq-ref details 'compression))
+ (filename
+ (store-path-base
+ (assq-ref details 'store-path))))
+
+ (let ((files-hash
+ (assq-ref files-by-compression compression)))
+ (if (hash-ref files-hash filename)
+ (hash-remove! files-hash filename)
+
+ ;; Database entry, but file missing
+ (set! database-entries-missing-files
+ (cons details
+ database-entries-missing-files))))
+
+ `((,compression . ,(+ (assq-ref details 'size)
+ (or (assq-ref result compression)
+ 0)))
+ ,@(alist-delete compression result))))
+ (map
+ (lambda (compression)
+ (cons compression 0))
+ (map car enabled-cached-compressions)))))
+
+ ;; Delete cached files with no database entries
+ (for-each
+ (match-lambda
+ ((compression . hash-table)
+ (let ((count (hash-count (const #t)
+ hash-table)))
+ (unless (= 0 count)
+ (let ((directory
+ (assq-ref
+ (assq-ref enabled-cached-compressions compression)
+ 'directory)))
+ (simple-format #t "deleting ~A cached files from ~A\n"
+ count
+ directory)
+ (hash-for-each
+ (lambda (filename _)
+ (delete-file (string-append directory "/" filename)))
+ hash-table))))))
+ files-by-compression)
+
+ ;; Delete database entries where the file is missing
+ (let ((count (length database-entries-missing-files)))
+ (unless (= 0 count)
+ (simple-format
+ #t
+ "deleting ~A cached_narinfo_files entries due to missing files\n"
+ count)
+
+ (for-each
+ (lambda (details)
+ (database-remove-cached-narinfo-file database
+ (assq-ref details 'narinfo-id)
+ (symbol->string
+ (assq-ref details 'compression))))
+ database-entries-missing-files)))
+
+ ;; Remove cached files if the max size is exceeded
+ (for-each
+ (match-lambda
+ ((compression . cached-bytes)
+ (maybe-remove-cached-files-for-compression
+ database
+ enabled-cached-compressions
+ compression
+ cached-bytes-by-compression)))
+ cached-bytes-by-compression)
+
+ cached-bytes-by-compression))
+
+(define (maybe-remove-cached-files-for-compression database
+ enabled-cached-compressions
+ compression
+ cached-bytes-by-compression)
+ ;; TODO Implement
+ #f)
+
+(define* (make-maybe-trigger-creation-of-compressed-nars
+ database
+ canonical-storage
+ enabled-cached-compressions
+ cached-compression-min-uses
+ #:key (cached-compression-workers 2))
+
+ (let ((consider-nar-request-channel
+ (make-worker-thread-channel
+ (lambda ()
+ (let ((cached-bytes-by-compression-box
+ (make-atomic-box #f)))
+ (atomic-box-set!
+ cached-bytes-by-compression-box
+ (perform-cached-compression-startup database
+ enabled-cached-compressions))
+ (list cached-bytes-by-compression-box)))
+ ;; Just make one thread, as this thread won't do much work
+ ;; and relies on a hash table that shouldn't be accessed by
+ ;; multiple threads
+ #:parallelism 1)))
+
+ (define with-usage-hash-table
+ (let ((nar-cached-compression-usage-hash-table
+ (make-hash-table 65536)))
+ (lambda (proc)
+ (monitor
+ (proc nar-cached-compression-usage-hash-table)))))
+
+ (define (proc narinfo-id cached-bytes-by-compression-box)
+ (peek "NARINFO ID" narinfo-id)
+ (let* ((existing-cached-files
+ ;; This is important both to avoid trying to create
+ ;; files twice, but also in the case where additional
+ ;; compressions are enabled and more files need to be
+ ;; generated
+ (database-select-cached-narinfo-files-by-narinfo-id
+ database
+ narinfo-id))
+ (existing-compressions
+ (map (lambda (details)
+ (assq-ref details 'compression))
+ existing-cached-files))
+ (missing-compressions
+ (lset-difference eq?
+ (map car enabled-cached-compressions)
+ existing-compressions)))
+
+ (unless (null? missing-compressions)
+ (let ((new-count
+ (with-usage-hash-table
+ (lambda (usage)
+ (let ((val (+ 1
+ (or (hash-ref usage narinfo-id)
+ 0))))
+ (hash-set! usage
+ narinfo-id
+ val)
+ val)))))
+
+ (when (> new-count
+ cached-compression-min-uses)
+ (for-each
+ (lambda (missing-compression)
+ (let ((new-bytes
+ (make-compressed-nar
+ database
+ canonical-storage
+ enabled-cached-compressions
+ narinfo-id
+ missing-compression)))
+
+ ;; Do this here, after creating the new cached nar,
+ ;; just in case there's a lack of space
+ (monitor
+ (let* ((cached-bytes-by-compression
+ (atomic-box-ref
+ cached-bytes-by-compression-box)))
+ (atomic-box-set!
+ cached-bytes-by-compression-box
+ (alist-cons
+ missing-compression
+ (+ (assq-ref cached-bytes-by-compression
+ missing-compression)
+ new-bytes)
+ (alist-delete
+ missing-compression
+ cached-bytes-by-compression)))
+
+ (maybe-remove-cached-files-for-compression
+ database
+ enabled-cached-compressions
+ missing-compression
+ cached-bytes-by-compression)))))
+ missing-compressions)
+
+ (with-usage-hash-table
+ (lambda (usage)
+ (hash-remove! usage narinfo-id))))))))
+
+ (let ((process-job
+ count-jobs
+ count-threads
+ list-jobs
+ (create-work-queue cached-compression-workers
+ proc)))
+
+ (lambda (narinfo-id)
+ (call-with-worker-thread
+ consider-nar-request-channel
+ (lambda (cached-bytes-by-compression-box)
+ (let ((in-progress-narinfo-ids
+ (map car (list-jobs))))
+
+ (unless (member narinfo-id in-progress-narinfo-ids)
+ (process-job narinfo-id cached-bytes-by-compression-box)))
+ #t))))))
+
+(define (make-compressed-nar database
+ canonical-storage
+ enabled-cached-compressions
+ narinfo-id
+ target-compression)
+ (define cached-compression-details
+ (assq-ref enabled-cached-compressions target-compression))
+
+ (define narinfo-files
+ (database-select-narinfo-files-by-narinfo-id database
+ narinfo-id))
+
+ (let* ((source-narinfo-file
+ ;; There's no specific logic to this, it should be possible
+ ;; to use any file
+ (first narinfo-files))
+ (source-filename
+ (string-append
+ canonical-storage
+ (assq-ref source-narinfo-file 'url))))
+
+ (let* ((dest-directory
+ (assq-ref cached-compression-details
+ 'directory))
+ (dest-filename
+ (string-append
+ dest-directory
+ "/" (last
+ (string-split source-filename #\/))))
+ (tmp-dest-filename
+ (string-append dest-filename ".tmp")))
+
+ (when (file-exists? tmp-dest-filename)
+ (delete-file tmp-dest-filename))
+ (when (file-exists? dest-filename)
+ (delete-file dest-filename))
+
+ (mkdir-p dest-directory)
+
+ (call-with-input-file
+ source-filename
+ (lambda (source-port)
+ (call-with-decompressed-port
+ (string->symbol
+ (assq-ref source-narinfo-file
+ 'compression))
+ source-port
+ (lambda (decompressed-source-port)
+ (call-with-compressed-output-port
+ target-compression
+ (open-output-file tmp-dest-filename)
+ (lambda (compressed-port)
+ (dump-port decompressed-source-port
+ compressed-port)))))))
+ (rename-file
+ tmp-dest-filename
+ dest-filename)
+
+ (let ((bytes
+ (stat:size (stat dest-filename))))
+
+ (database-insert-cached-narinfo-file
+ database
+ narinfo-id
+ bytes
+ (symbol->string target-compression))
+
+ bytes))))
diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index d945786..028fb50 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -51,8 +51,15 @@
database-select-narinfo-for-file
database-select-narinfo-files
+ database-select-narinfo-files-by-narinfo-id
- database-map-all-narinfo-files))
+ database-map-all-narinfo-files
+
+ database-insert-cached-narinfo-file
+ database-select-cached-narinfo-file-by-hash
+ database-select-cached-narinfo-files-by-narinfo-id
+ database-fold-cached-narinfo-files
+ database-remove-cached-narinfo-file))
(define-record-type <database>
(make-database database-file reader-thread-channel writer-thread-channel
@@ -122,7 +129,17 @@ CREATE TABLE recent_changes (
datetime TEXT NOT NULL,
change TEXT NOT NULl,
data TEXT NOT NULL
-);")
+);
+
+CREATE TABLE cached_narinfo_files (
+ id INTEGER PRIMARY KEY ASC,
+ narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
+ size INTEGER NOT NULL,
+ compression TEXT,
+);
+
+CREATE INDEX cached_narinfo_files_narinfo_id
+ ON cached_narinfo_files (narinfo_id);")
(sqlite-exec db schema))
@@ -149,6 +166,20 @@ SELECT 1 FROM sqlite_master WHERE type = 'table' AND name = :name")))
(unless (table-exists? db "narinfos")
(perform-initial-database-setup db))
+ (unless (table-exists? db "cached_narinfo_files")
+ (sqlite-exec
+ db
+ "
+CREATE TABLE cached_narinfo_files (
+ id INTEGER PRIMARY KEY ASC,
+ narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
+ size INTEGER NOT NULL,
+ compression TEXT NOT NULL
+);
+
+CREATE INDEX cached_narinfo_files_narinfo_id
+ ON cached_narinfo_files (narinfo_id);"))
+
(sqlite-exec
db
"CREATE INDEX IF NOT EXISTS narinfo_files_narinfo_id
@@ -285,11 +316,13 @@ PRAGMA optimize;")))
(make-histogram-metric registry
metric-name)))
(start-time (get-internal-real-time)))
- (let ((result (thunk)))
- (metric-observe metric
- (/ (- (get-internal-real-time) start-time)
- internal-time-units-per-second))
- result))
+ (call-with-values
+ thunk
+ (lambda vals
+ (metric-observe metric
+ (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second))
+ (apply values vals))))
(thunk)))
(define %current-transaction-proc
@@ -715,7 +748,7 @@ DELETE FROM narinfo_tags WHERE narinfo_id = :narinfo_id"
(sqlite-prepare
db
"
-SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
+SELECT id, contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
#:cache? #t)))
(sqlite-bind-arguments
statement
@@ -724,8 +757,10 @@ SELECT contents FROM narinfos WHERE substr(store_path, 12, 32) = :hash"
(match (let ((result (sqlite-step statement)))
(sqlite-reset statement)
result)
- (#(contents) contents)
- (_ #f))))))))
+ (#(id contents)
+ (values contents id))
+ (_
+ (values #f #f)))))))))
(define* (database-select-recent-changes database after-date #:key (limit 8192))
(call-with-worker-thread
@@ -859,7 +894,7 @@ WHERE narinfo_files.url = :url"
(sqlite-prepare
db
"
-SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url
+SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url, narinfos.id
FROM narinfos
INNER JOIN narinfo_files
ON narinfos.id = narinfo_files.narinfo_id
@@ -873,6 +908,42 @@ WHERE substr(narinfos.store_path, 12, 32) = :hash"
(let ((result
(sqlite-map
(match-lambda
+ (#(size compression url narinfo-id)
+ `((size . ,size)
+ (compression . ,compression)
+ (url . ,url)
+ (narinfo-id . ,narinfo-id))))
+ statement)))
+ (sqlite-reset statement)
+
+ result)))))))
+
+(define (database-select-narinfo-files-by-narinfo-id database narinfo-id)
+ (call-with-time-tracking
+ database
+ "select_narinfo_files_by_narinfo_id"
+ (lambda ()
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT narinfo_files.size, narinfo_files.compression, narinfo_files.url
+FROM narinfos
+INNER JOIN narinfo_files
+ ON narinfos.id = narinfo_files.narinfo_id
+WHERE narinfos.id = :narinfo_id"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:narinfo_id narinfo-id)
+
+ (let ((result
+ (sqlite-map
+ (match-lambda
(#(size compression url)
`((size . ,size)
(compression . ,compression)
@@ -907,3 +978,156 @@ FROM narinfo_files"
(sqlite-reset statement)
result-list)))))
+
+(define (database-insert-cached-narinfo-file database
+ narinfo-id
+ size
+ compression)
+ (call-with-worker-thread
+ (database-writer-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+INSERT INTO cached_narinfo_files (
+ narinfo_id, size, compression
+) VALUES (
+ :narinfo_id, :size, :compression
+)"
+ #:cache? #t)))
+ (sqlite-bind-arguments
+ statement
+ #:narinfo_id narinfo-id
+ #:size size
+ #:compression compression)
+
+ (sqlite-step statement)
+ (sqlite-reset statement)
+
+ (last-insert-rowid db)))))
+
+(define (database-select-cached-narinfo-file-by-hash database
+ hash
+ compression)
+ (call-with-time-tracking
+ database
+ "select_cached_narinfo_file_by_hash"
+ (lambda ()
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT cached_narinfo_files.size
+FROM narinfos
+INNER JOIN cached_narinfo_files
+ ON cached_narinfo_files.narinfo_id = narinfos.id
+WHERE substr(narinfos.store_path, 12, 32) = :hash
+ AND cached_narinfo_files.compression = :compression"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:hash hash
+ #:compression compression)
+
+ (let ((result
+ (match (sqlite-step statement)
+ (#(size)
+ `((size . ,size)))
+ (#f #f))))
+ (sqlite-reset statement)
+
+ result)))))))
+
+(define (database-select-cached-narinfo-files-by-narinfo-id
+ database
+ narinfo-id)
+ (call-with-time-tracking
+ database
+ "select_cached_narinfo_file_by_narinfo_id"
+ (lambda ()
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT store_path, size, compression
+FROM cached_narinfo_files
+INNER JOIN narinfos
+ ON cached_narinfo_files.narinfo_id = narinfos.id
+WHERE narinfo_id = :narinfo_id"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:narinfo_id narinfo-id)
+
+ (let ((result
+ (sqlite-map
+ (match-lambda
+ (#(store_path size compression)
+ `((store-path . ,store_path)
+ (size . ,size)
+ (compression . ,(string->symbol compression)))))
+ statement)))
+ (sqlite-reset statement)
+
+ result)))))))
+
+(define (database-fold-cached-narinfo-files database
+ proc
+ init)
+ (call-with-worker-thread
+ (database-reader-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT store_path, size, compression, narinfo_id
+FROM cached_narinfo_files
+INNER JOIN narinfos
+ ON cached_narinfo_files.narinfo_id = narinfos.id"
+ #:cache? #t)))
+ (let ((result-list
+ (sqlite-fold
+ (lambda (row result)
+ (match row
+ (#(store_path size compression narinfo_id)
+ (proc `((size . ,size)
+ (compression . ,(string->symbol compression))
+ (store-path . ,store_path)
+ (narinfo-id . ,narinfo_id))
+ result))))
+ init
+ statement)))
+ (sqlite-reset statement)
+
+ result-list)))))
+
+(define (database-remove-cached-narinfo-file database narinfo-id compression)
+ (call-with-worker-thread
+ (database-writer-thread-channel database)
+ (lambda (db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+DELETE FROM cached_narinfo_files
+WHERE narinfo_id = :narinfo_id
+ AND compression = :compression"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:narinfo_id narinfo-id
+ #:compression compression)
+
+ (sqlite-step statement)
+ (sqlite-reset statement)))))
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 522ff3f..f188488 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -20,13 +20,16 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
#:use-module (ice-9 binary-ports)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
#:use-module (web response)
#:use-module (web request)
#:use-module (logging logger)
+ #:use-module (fibers)
#:use-module (prometheus)
#:use-module (json)
#:use-module ((system foreign)
@@ -41,7 +44,12 @@
#:use-module (nar-herder database)
#:use-module (nar-herder storage)
#:use-module (ice-9 textual-ports)
- #:export (make-request-handler))
+ #:export (%compression-options
+
+ make-request-handler))
+
+(define %compression-options
+ '(gzip lzip zstd none))
(define* (render-json json #:key (extra-headers '())
(code 200))
@@ -147,9 +155,36 @@
(proc port size)))))
+(define (add-cached-compressions-to-narinfo
+ database
+ narinfo-id
+ initial-narinfo-contents)
+ (let ((cached-nar-strings
+ (map (lambda (cached-nar-details)
+ (let ((compression
+ (symbol->string
+ (assq-ref cached-nar-details 'compression))))
+ (string-append
+ "URL: nar/" compression "/"
+ (store-path-base
+ (assq-ref cached-nar-details 'store-path))
+ "\n"
+ "Compression: " compression "\n"
+ "FileSize: " (number->string
+ (assq-ref cached-nar-details 'size)))))
+ (database-select-cached-narinfo-files-by-narinfo-id
+ database
+ narinfo-id))))
+ (string-append
+ initial-narinfo-contents
+ (string-join
+ cached-nar-strings
+ "\n"))))
+
(define* (make-request-handler database storage-root
#:key ttl negative-ttl logger
- metrics-registry)
+ metrics-registry
+ maybe-trigger-creation-of-compressed-nars)
(define (narinfo? str)
(and
(= (string-length str) 40)
@@ -168,6 +203,10 @@
#:label-values `((category . ,category)
(response_code . ,response-code))))
+ (define %compression-strings
+ (map symbol->string
+ %compression-options))
+
(lambda (request body)
(log-msg logger
'DEBUG
@@ -179,22 +218,29 @@
(split-and-decode-uri-path
(uri-path (request-uri request))))
(('GET (? narinfo? narinfo))
- (let ((narinfo-contents
+ (let ((base-narinfo-contents
+ narinfo-id
(database-select-narinfo-contents-by-hash
database
(string-take narinfo 32))))
(increment-request-metric "narinfo"
- (if narinfo-contents
+ (if base-narinfo-contents
"200"
"404"))
- (if narinfo-contents
- (values `((content-type . (text/plain))
- ,@(if ttl
- `((cache-control (max-age . ,ttl)))
- '()))
- narinfo-contents)
+ (if base-narinfo-contents
+ (let ((narinfo-contents
+ (add-cached-compressions-to-narinfo
+ database
+ narinfo-id
+ base-narinfo-contents)))
+
+ (values `((content-type . (text/plain))
+ ,@(if ttl
+ `((cache-control (max-age . ,ttl)))
+ '()))
+ narinfo-contents))
(values (build-response #:code 404
#:headers (if negative-ttl
`((cache-control
@@ -230,28 +276,59 @@
(find (lambda (file)
(string=? (assq-ref file 'compression)
compression))
- narinfo-files)))
+ narinfo-files))
+ (compression-symbol
+ (if (member
+ compression
+ %compression-strings
+ string=?)
+ (string->symbol compression)
+ #f)))
(when (or narinfo-file-for-compression
;; Check for a common compression to avoid lots of
;; metrics being generated if compression is random
- (member compression '("gzip" "lzip" "zstd")))
+ compression-symbol)
(increment-request-metric
(string-append "nar/"
compression)
(if narinfo-file-for-compression "200" "404")))
(if narinfo-file-for-compression
- (values (build-response
- #:code 200
- #:headers `((X-Accel-Redirect
- . ,(string-append
- "/internal/nar/"
- compression "/"
- (uri-encode filename)))))
- #f)
- (values (build-response #:code 404)
- "404"))))
+ (begin
+ (when maybe-trigger-creation-of-compressed-nars
+ (spawn-fiber
+ (lambda ()
+ (maybe-trigger-creation-of-compressed-nars
+ (assq-ref narinfo-file-for-compression
+ 'narinfo-id)))
+ #:parallel? #t))
+
+ (values (build-response
+ #:code 200
+ #:headers `((X-Accel-Redirect
+ . ,(string-append
+ "/internal/nar/"
+ compression "/"
+ (uri-encode filename)))))
+ #f))
+ (let ((cached-narinfo-file
+ (and compression-symbol
+ (database-select-cached-narinfo-file-by-hash
+ database
+ hash
+ compression))))
+ (if cached-narinfo-file
+ (values (build-response
+ #:code 200
+ #:headers `((X-Accel-Redirect
+ . ,(string-append
+ "/internal/cached-nar/"
+ compression "/"
+ (uri-encode filename)))))
+ #f)
+ (values (build-response #:code 404)
+ "404"))))))
(('GET "file" name algo hash)
(guard (c ((invalid-base32-character? c)
(values (build-response #:code 404)
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index d1f95d1..9058783 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -58,6 +58,7 @@
(nar-herder utils)
(nar-herder database)
(nar-herder recent-changes)
+ (nar-herder cached-compression)
(nar-herder storage)
(nar-herder mirror)
(nar-herder server))
@@ -136,6 +137,48 @@
(call-with-input-string rest read))))
result)))
+ (option '("enable-cached-compression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cached-compression
+ (match (string-split arg #\:)
+ ((type)
+ `((type . ,(string->symbol type))))
+ ((type level)
+ `((type . ,(string->symbol type))
+ (level . ,level))))
+ result)))
+
+ (option '("cached-compression-directory") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cached-compression-directory
+ (match (string-split arg #\=)
+ ((type directory)
+ (cons (string->symbol type)
+ (canonicalize-path directory))))
+ result)))
+
+ (option '("cached-compression-directory-max-size") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cached-compression-directory-max-size
+ (match (string-split arg #\=)
+ ((type size)
+ (cons (string->symbol type)
+ (string->number size))))
+ result)))
+
+ (option '("cached-compression-min-uses") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cached-compression-min-uses
+ (string->number min-uses)
+ (alist-delete 'cached-compression-min-uses
+ result))))
+
+ (option '("cached-compression-workers") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cached-compression-workers
+ (string->number arg)
+ result)))
+
(option '("ttl") #t #f
(lambda (opt name arg result)
(let ((duration (string->duration arg)))
@@ -158,7 +201,7 @@
result))))
(option '("recent-changes-limit") #t #f
- (lambda (opt name arg result)
+ (lambda (opt name arg result)+
(alist-cons 'recent-changes-limit
(string->number arg)
(alist-delete 'recent-changes-limit result))))
@@ -188,6 +231,10 @@
(log-level . DEBUG)
(storage-limit . "none")
+
+ (cached-compression-workers . 2)
+ (cached-compression-min-uses . 3)
+
(recent-changes-limit . 32768)))
(define (parse-options options defaults args)
@@ -393,10 +440,46 @@
#f)
(download-database)))))
- (let ((database (setup-database (assq-ref opts 'database)
- metrics-registry))
- (canonical-storage (and=> (assq-ref opts 'storage)
- canonicalize-path)))
+ (let* ((database (setup-database (assq-ref opts 'database)
+ metrics-registry))
+ (canonical-storage (and=> (assq-ref opts 'storage)
+ canonicalize-path))
+
+ (enabled-cached-compressions
+ (let ((explicit-cached-compression-directories
+ (filter-map
+ (match-lambda
+ (('cached-compression-directory . details) details)
+ (_ #f))
+ opts)))
+ (filter-map
+ (match-lambda
+ (('cached-compression . details)
+ (let ((compression
+ (assq-ref details 'type)))
+ (cons compression
+ `(,@(alist-delete 'type details)
+ (directory
+ . ,(or (assq-ref explicit-cached-compression-directories
+ compression)
+ (simple-format #f "/var/cache/nar-herder/nar/~A"
+ compression)))))))
+ (_ #f))
+ opts)))
+
+ (cached-compression-min-uses
+ (assq-ref opts 'cached-compression-min-uses))
+
+ (maybe-trigger-creation-of-compressed-nars
+ (if (null? enabled-cached-compressions)
+ #f
+ (make-maybe-trigger-creation-of-compressed-nars
+ database
+ canonical-storage
+ enabled-cached-compressions
+ cached-compression-min-uses
+ #:cached-compression-workers
+ (assq-ref opts 'cached-compression-workers)))))
(when (not (file-exists? (assq-ref opts 'database-dump)))
(log-msg 'INFO "dumping database...")
@@ -445,6 +528,8 @@
#:ttl (assq-ref opts 'narinfo-ttl)
#:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
#:logger lgr
- #:metrics-registry metrics-registry)
+ #:metrics-registry metrics-registry
+ #:maybe-trigger-creation-of-compressed-nars
+ maybe-trigger-creation-of-compressed-nars)
#:host (assq-ref opts 'host)
#:port (assq-ref opts 'port))))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-03 18:09:18 +0000