Add experimental support for cached compressions

This adds optional caching for alternative compressions of stored
nars. You could store lzip nars for example, but then compute, cache
and provide zstd nars for some stored nars.

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))))))