[no subject]

[Mathieu Othacehe]

branch: master
commit 38b8edc338e443fe1c0780479b8d39763f98f579
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Mon Oct 4 10:50:29 2021 +0000

    Add a debug parameter and improve logging.
    
    * src/cuirass/parameters.scm (%debug): New parameter.
    * src/cuirass/scripts/remote-server.scm: Improve logging.
---
 src/cuirass/parameters.scm            |  7 ++++-
 src/cuirass/scripts/remote-server.scm | 54 ++++++++++++++++++++++++-----------
 2 files changed, 43 insertions(+), 18 deletions(-)

diff --git a/src/cuirass/parameters.scm b/src/cuirass/parameters.scm
index eee1b46..c8e3bbf 100644
--- a/src/cuirass/parameters.scm
+++ b/src/cuirass/parameters.scm
@@ -17,7 +17,9 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass parameters)
-  #:export (%cuirass-database
+  #:export (%debug
+
+            %cuirass-database
             %cuirass-host
             %cuirass-url
 
@@ -32,6 +34,9 @@
 ;; This variable is looked up by 'mu-message-send'.
 (define-public mu-debug 0)
 
+(define %debug
+  (make-parameter #true))
+
 ;; The Cuirass PostgreSQL database name.
 (define %cuirass-database
   (make-parameter "cuirass"))
diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index 96e9632..8f94b23 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -23,6 +23,7 @@
   #:use-module (cuirass logging)
   #:use-module (cuirass ui)
   #:use-module (cuirass notification)
+  #:use-module (cuirass parameters)
   #:use-module (cuirass remote)
   #:use-module (cuirass utils)
   #:use-module (gcrypt pk-crypto)
@@ -242,26 +243,45 @@ be used to reply to the worker."
      (reply-worker
       (zmq-server-info (zmq-remote-address msg) (%log-port) (%publish-port))))
     (('worker-request-work name)
-     (let ((build (pop-build name)))
-       (if build
-           (let ((derivation (assq-ref build #:derivation))
-                 (priority (assq-ref build #:priority))
-                 (timeout (assq-ref build #:timeout))
-                 (max-silent (assq-ref build #:max-silent)))
-             (db-update-build-worker! derivation name)
-             (db-update-build-status! derivation (build-status submitted))
-             (reply-worker
-              (zmq-build-request-message derivation
-                                         #:priority priority
-                                         #:timeout timeout
-                                         #:max-silent max-silent)))
-           (reply-worker
-            (zmq-no-build-message)))))
+     (let ((worker (db-get-worker name)))
+       (when (%debug)
+         (log-message "~a (~a): request work."
+                      (worker-address worker)
+                      (worker-name worker)))
+       (let ((build (pop-build name)))
+         (if build
+             (let ((derivation (assq-ref build #:derivation))
+                   (priority (assq-ref build #:priority))
+                   (timeout (assq-ref build #:timeout))
+                   (max-silent (assq-ref build #:max-silent)))
+               (when (%debug)
+                 (log-message "~a (~a): build ~a submitted."
+                              (worker-address worker)
+                              (worker-name worker)
+                              derivation))
+               (db-update-build-worker! derivation name)
+               (db-update-build-status! derivation (build-status submitted))
+               (reply-worker
+                (zmq-build-request-message derivation
+                                           #:priority priority
+                                           #:timeout timeout
+                                           #:max-silent max-silent)))
+             (begin
+               (when (%debug)
+                 (log-message "~a (~a): no available build."
+                              (worker-address worker)
+                              (worker-name worker)))
+               (reply-worker
+                (zmq-no-build-message)))))))
     (('worker-ping worker)
      (update-worker! worker))
     (('build-started ('drv drv) ('worker worker))
-     (let ((log-file (log-path (%cache-directory) drv)))
-       (log-message "build started: '~a' on ~a." drv worker)
+     (let ((log-file (log-path (%cache-directory) drv))
+           (worker (db-get-worker worker)))
+       (log-message "~a (~a): build started: '~a'."
+                    (worker-address worker)
+                    (worker-name worker)
+                    drv)
        (db-update-build-worker! drv worker)
        (db-update-build-status! drv (build-status started)
                                 #:log-file log-file)))))