[no subject]

[Ludovic Courtès]

branch: main
commit aefc013ed5fa713f16e3228b59c3ea25889fbbb1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 31 08:46:15 2024 +0200

    Revert "remote-worker: Send pings on each loop iteration."
    
    This reverts commit da20c3b653f30649a7e135ba886b948310903e32, which
    caused workers to not send pings while they’re building things.
---
 src/cuirass/scripts/remote-worker.scm | 40 ++++++++++++++++++++---------------
 1 file changed, 23 insertions(+), 17 deletions(-)

diff --git a/src/cuirass/scripts/remote-worker.scm 
b/src/cuirass/scripts/remote-worker.scm
index 565757e..d4f39fd 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -1,6 +1,6 @@
 ;;; remote-worker.scm -- Remote build worker.
 ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2022-2024 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -27,7 +27,7 @@
   #:use-module (cuirass logging)
   #:use-module (cuirass remote)
   #:use-module (cuirass ui)
-  #:autoload   (cuirass utils) (gather-user-privileges with-timing-check)
+  #:autoload   (cuirass utils) (gather-user-privileges)
   #:use-module (gcrypt pk-crypto)
   #:use-module (guix avahi)
   #:use-module (guix config)
@@ -285,6 +285,25 @@ command.  REPLY is a procedure that can be used to reply 
to this server."
                 #:timeout timeout
                 #:max-silent max-silent))))
 
+(define (spawn-worker-ping worker server)
+  "Spawn a thread that periodically pings SERVER."
+  (define (ping socket)
+    (send-message socket
+                  (worker-ping (worker->sexp worker))))
+
+  (spawn-fiber
+   (lambda ()
+     (let* ((socket (zmq-dealer-socket))
+            (address (server-address server))
+            (port (server-port server))
+            (endpoint (zmq-backend-endpoint address port)))
+       (zmq-connect socket endpoint)
+       (let loop ()
+         (log-info (G_ "~a: ping ~a.") (worker-name worker) endpoint)
+         (ping socket)
+         (sleep 60)
+         (loop))))))
+
 (define (low-disk-space?)
   "Return true if disk space is low."
   (or (< (free-disk-space (%store-prefix)) (%minimum-disk-space))
@@ -356,18 +375,12 @@ process can use up to PARALLELISM cores."
        (let* ((srv-info (read-server-info socket))
               (server (server-info->server srv-info serv))
               (worker (server-info->worker srv-info wrk)))
-         (define (ping socket)
-           (send-message socket
-                         (worker-ping (worker->sexp worker))))
-
          (log-info (G_ "server publish URL: ~a; server log port: ~a")
                    (server-publish-url server)
                    (server-log-port server))
          (ready socket worker)
+         (spawn-worker-ping worker server)
          (let loop ()
-           (log-info (G_ "~a: ping ~a.") (worker-name worker) endpoint)
-           (ping socket)
-
            (if (low-disk-space?)
                (begin
                  (log-info (G_ "warning: low disk space, doing nothing"))
@@ -375,14 +388,7 @@ process can use up to PARALLELISM cores."
                (begin
                  (log-info (G_ "~a: request work.") (worker-name wrk))
                  (request-work socket worker)
-
-                 ;; Note: While waiting for the server to reply, we don't send
-                 ;; any ping.  Thus, we might as well be considered
-                 ;; "unresponsive" by the server even though the problem is on
-                 ;; its side.
-                 (match (with-timing-check "receiving work from server"
-                          (receive-message socket)
-                          #:threshold 60)
+                 (match (receive-message socket)
                    ((? unspecified?)              ;server reconnect
                     (log-info (G_ "~a: received a bootstrap message.")
                               (worker-name wrk)))