[no subject]

[Mathieu Othacehe]

branch: master
commit df2e9450059ebd1cd5e3f267ae0e162583965793
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Wed May 19 09:49:38 2021 +0200

    remote-worker: Add a TTL argument.
    
    Add a TTL argument and use it to register GC roots for the successfully 
built
    items.
    
    * src/cuirass/scripts/remote-worker.scm (show-help): Add a TTL argument.
    (%options): Ditto.
    (%default-options): Ditto.
    (run-build): Register GC roots for the successfully built derivation 
outputs.
    (remote-worker): Add a TTL argument.
---
 src/cuirass/scripts/remote-worker.scm | 110 +++++++++++++++++++---------------
 1 file changed, 61 insertions(+), 49 deletions(-)

diff --git a/src/cuirass/scripts/remote-worker.scm 
b/src/cuirass/scripts/remote-worker.scm
index 67bc076..0e9df9f 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -44,6 +44,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
@@ -71,6 +72,8 @@ Start a remote build worker.\n" (%program-name))
   (display (G_ "
   -p, --publish-port=PORT   publish substitutes on PORT"))
   (display (G_ "
+  -t, --ttl=DURATION        keep build results live for at least DURATION"))
+  (display (G_ "
   -s, --server=SERVER       connect to SERVER"))
   (display (G_ "
   -S, --systems=SYSTEMS     list of supported SYSTEMS"))
@@ -100,6 +103,9 @@ Start a remote build worker.\n" (%program-name))
         (option '(#\p "publish-port") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'publish-port (string->number* arg) result)))
+        (option '(#\t "ttl") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'ttl arg result)))
         (option '(#\s "server") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'server arg result)))
@@ -117,6 +123,7 @@ Start a remote build worker.\n" (%program-name))
 (define %default-options
   `((workers . 1)
     (publish-port . 5558)
+    (ttl . "3d")
     (systems . ,(list (%current-system)))
     (public-key-file . ,%public-key-file)
     (private-key-file . ,%private-key-file)))
@@ -187,6 +194,7 @@ still be substituted."
           (if result
               (begin
                 (info (G_ "Derivation ~a build succeeded.~%") drv)
+                (register-gc-roots drv)
                 (reply (zmq-build-succeeded-message drv local-publish-url)))
               (begin
                 (info (G_ "Derivation ~a build failed.~%") drv)
@@ -361,6 +369,7 @@ 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))
            (public-key
@@ -370,52 +379,55 @@ exiting."
             (read-file-sexp
              (assoc-ref opts 'private-key-file))))
 
-      (atomic-box-set! %local-publish-port publish-port)
-
-      (atomic-box-set!
-       %publish-pid
-       (publish-server publish-port
-                       #:public-key public-key
-                       #:private-key private-key))
-
-      (if server-address
-          (for-each
-           (lambda (n)
-             (let* ((worker (worker
-                             (name (generate-worker-name))
-                             (machine (gethostname))
-                             (systems systems)))
-                    (addr (string-split server-address #\:))
-                    (server (match addr
-                              ((address port)
-                               (server
-                                (address address)
-                                (port (string->number port)))))))
-               (add-to-worker-pids!
-                (start-worker worker server))))
-           (iota workers))
-          (avahi-browse-service-thread
-           (lambda (action service)
-             (case action
-               ((new-service)
-                (for-each
-                 (lambda (n)
-                   (let* ((address (avahi-service-local-address service))
-                          (publish-url (local-publish-url address)))
-                     (add-to-worker-pids!
-                      (start-worker (worker
-                                     (name (generate-worker-name))
-                                     (address address)
-                                     (machine (gethostname))
-                                     (publish-url publish-url)
-                                     (systems systems))
-                                    (avahi-service->server service)))))
-                 (iota workers))
-                (atomic-box-set! %stop-process? #t))))
-           #:ignore-local? #f
-           #:types (list remote-server-service-type)
-           #:stop-loop? (lambda ()
-                          (atomic-box-ref %stop-process?))))
-
-      (while #t
-        (sleep 1)))))
+      (parameterize
+          ((%gc-root-ttl
+            (time-second (string->duration ttl))))
+        (atomic-box-set! %local-publish-port publish-port)
+
+        (atomic-box-set!
+         %publish-pid
+         (publish-server publish-port
+                         #:public-key public-key
+                         #:private-key private-key))
+
+        (if server-address
+            (for-each
+             (lambda (n)
+               (let* ((worker (worker
+                               (name (generate-worker-name))
+                               (machine (gethostname))
+                               (systems systems)))
+                      (addr (string-split server-address #\:))
+                      (server (match addr
+                                ((address port)
+                                 (server
+                                  (address address)
+                                  (port (string->number port)))))))
+                 (add-to-worker-pids!
+                  (start-worker worker server))))
+             (iota workers))
+            (avahi-browse-service-thread
+             (lambda (action service)
+               (case action
+                 ((new-service)
+                  (for-each
+                   (lambda (n)
+                     (let* ((address (avahi-service-local-address service))
+                            (publish-url (local-publish-url address)))
+                       (add-to-worker-pids!
+                        (start-worker (worker
+                                       (name (generate-worker-name))
+                                       (address address)
+                                       (machine (gethostname))
+                                       (publish-url publish-url)
+                                       (systems systems))
+                                      (avahi-service->server service)))))
+                   (iota workers))
+                  (atomic-box-set! %stop-process? #t))))
+             #:ignore-local? #f
+             #:types (list remote-server-service-type)
+             #:stop-loop? (lambda ()
+                            (atomic-box-ref %stop-process?))))
+
+        (while #t
+          (sleep 1))))))