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.

1 files changed, 91 insertions, 6 deletions

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