From 337b74cdc3ca89430225e1758156a4ca62e0fdc2 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 16 Jan 2023 18:04:03 +0000
Subject: 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.
---
 scripts/nar-herder.in | 97 +++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 91 insertions(+), 6 deletions(-)

(limited to 'scripts')

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))))))
-- 
cgit v1.2.3