[no subject]

[Ludovic Courtès]

branch: master
commit ab3265bad0352275efe036848173d485fc2a41aa
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Oct 21 18:44:30 2023 +0200

    store: Remove ‘%gc-root-ttl’ parameter.
    
    This is a followup to 55af0f70c0d4938b8eda777382bbc4d8f5698a37.
    
    * src/cuirass/store.scm (%gc-root-ttl): Remove.
    * src/cuirass/scripts/register.scm (cuirass-register): Remove references
    to ‘%gc-root-ttl’.
    * src/cuirass/scripts/remote-server.scm (%options): Warn about ‘--ttl’
    having no effect.  Remove reference to ‘%gc-root-ttl’.
    * src/cuirass/scripts/remote-worker.scm (%options): Warn about ‘--ttl’
    having no effect.  Remove reference to ‘%gc-root-ttl’.
---
 src/cuirass/scripts/register.scm      | 10 +++++-----
 src/cuirass/scripts/remote-server.scm |  6 ++----
 src/cuirass/scripts/remote-worker.scm | 10 ++++------
 src/cuirass/store.scm                 |  7 +------
 4 files changed, 12 insertions(+), 21 deletions(-)

diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index 2d963d1..80de26b 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -28,7 +28,7 @@
   #:use-module (cuirass notification)
   #:use-module (cuirass specification)
   #:use-module ((cuirass store)
-                #:select (%gc-root-directory %gc-root-ttl))
+                #:select (%gc-root-directory))
   #:use-module (cuirass utils)
   #:use-module (cuirass zabbix)
   #:use-module (guix ui)
@@ -170,9 +170,7 @@
          (%package-database (option-ref opts 'database (%package-database)))
          (%package-cachedir
           (option-ref opts 'cache-directory (%package-cachedir)))
-         (%fallback? (option-ref opts 'fallback #f))
-         (%gc-root-ttl
-          (time-second (string->duration (option-ref opts 'ttl "30d")))))
+         (%fallback? (option-ref opts 'fallback #f)))
       (cond
        ((option-ref opts 'help #f)
         (show-help)
@@ -188,6 +186,8 @@
               (interval (string->number (option-ref opts 'interval "600")))
               (specfile (option-ref opts 'specifications #f))
               (paramfile (option-ref opts 'parameters #f))
+              (gc-root-ttl (time-second
+                            (string->duration (option-ref opts 'ttl "30d"))))
 
               ;; Since our work is mostly I/O-bound, default to a maximum of 8
               ;; kernel threads.  Going beyond that can increase overhead (GC
@@ -245,7 +245,7 @@
                        (spawn-bridge (open-bridge-socket) registry))
 
                      ;; Periodically delete old GC roots.
-                     (spawn-gc-root-cleaner (%gc-root-ttl))
+                     (spawn-gc-root-cleaner gc-root-ttl)
 
                      (spawn-fiber
                       (essential-task
diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index 2a80527..0bdb9ea 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -145,7 +145,8 @@ Start a remote build server.\n") (%program-name))
                   (alist-cons 'parameters arg result)))
         (option '(#\t "ttl") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'ttl arg result)))
+                  (warning (G_ "the '--ttl' option now has no effect~%"))
+                  result))
         (option '(#\D "database") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'database arg result)))
@@ -607,7 +608,6 @@ exiting."
                               (assoc-ref opts 'publish-port)))
            (cache (assoc-ref opts 'cache))
            (parameters (assoc-ref opts 'parameters))
-           (ttl (assoc-ref opts 'ttl))
            (database (assoc-ref opts 'database))
            (trigger-substitute-url (assoc-ref opts 'trigger-substitute-url))
            (user (assoc-ref opts 'user))
@@ -622,8 +622,6 @@ exiting."
                      (%publish-port publish-port)
                      (%trigger-substitute-url trigger-substitute-url)
                      (%package-database database)
-                     (%gc-root-ttl
-                      (time-second (string->duration ttl)))
                      (%public-key public-key)
                      (%private-key private-key))
 
diff --git a/src/cuirass/scripts/remote-worker.scm 
b/src/cuirass/scripts/remote-worker.scm
index b1a3bea..b6c2088 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -22,8 +22,7 @@
   #:use-module (fibers channels)
   #:autoload   (cuirass store) (build-derivations&
                                 register-gc-roots
-                                %gc-root-directory
-                                %gc-root-ttl)
+                                %gc-root-directory)
   #:use-module (cuirass logging)
   #:use-module (cuirass remote)
   #:use-module (cuirass ui)
@@ -124,7 +123,8 @@ Start a remote build worker.\n" (%program-name))
                   (alist-cons 'publish-port (string->number* arg) result)))
         (option '(#\t "ttl") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'ttl arg result)))
+                  (warning (G_ "the '--ttl' option now has no effect~%"))
+                  result))
         (option '("minimum-disk-space") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'minimum-disk-space
@@ -460,7 +460,6 @@ exiting."
                              %default-options))
            (workers (assoc-ref opts 'workers))
            (publish-port (assoc-ref opts 'publish-port))
-           (ttl (assoc-ref opts 'ttl))
            (server-address (assoc-ref opts 'server))
            (systems (assoc-ref opts 'systems))
            (urls    (assoc-ref opts 'substitute-urls))
@@ -473,8 +472,7 @@ exiting."
 
       (false-if-exception (mkdir-p (%gc-root-directory)))
 
-      (parameterize ((%gc-root-ttl (time-second (string->duration ttl)))
-                     (%substitute-urls urls)
+      (parameterize ((%substitute-urls urls)
                      (%minimum-disk-space
                       (assoc-ref opts 'minimum-disk-space)))
         (atomic-box-set! %local-publish-port publish-port)
diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
index e920f32..07658be 100644
--- a/src/cuirass/store.scm
+++ b/src/cuirass/store.scm
@@ -36,8 +36,7 @@
             register-gc-root
             register-gc-roots
             default-gc-root-directory
-            %gc-root-directory
-            %gc-root-ttl))
+            %gc-root-directory))
 
 
 ;;;
@@ -55,10 +54,6 @@
   ;; outputs there.
   (make-parameter (default-gc-root-directory)))
 
-(define %gc-root-ttl
-  ;; The "time to live" (TTL) of GC roots.
-  (make-parameter (* 30 24 3600)))
-
 (define (register-gc-root item)
   "Create a GC root pointing to ITEM, a store item."
   (let ((root (string-append (%gc-root-directory) "/" (basename item))))