branch wip-offload updated: tmp20

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch wip-offload
in repository guix-cuirass.

The following commit(s) were added to refs/heads/wip-offload by this push:
     new d080ec9  tmp20
d080ec9 is described below

commit d080ec9c6d8a306098f07cfca6dc3d24936790d1
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Fri Dec 18 09:56:44 2020 +0100

    tmp20
---
 src/cuirass/base.scm          | 6 +++++-
 src/cuirass/remote-server.scm | 9 ++++++++-
 src/cuirass/remote-worker.scm | 5 +++--
 src/cuirass/remote.scm        | 8 ++++----
 4 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 114bcbf..ddeab75 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -471,7 +471,7 @@ in the database."
            (let loop ()
              (remote-build-poll socket handle-build-event)
              (match (get-message-with-timeout channel
-                                              #:seconds 1
+                                              #:seconds 0.1
                                               #:retry? #f)
                ((drvs . systems)
                 (remote-build socket drvs systems))
@@ -666,6 +666,10 @@ updating the database accordingly."
            (log-message "build failed: '~a'" drv)
            (db-update-build-status! drv (build-status failed)))
          (log-message "bogus build-failed event for '~a'" drv)))
+    (('build-failed/log drv log)
+     (log-message "build failed: '~a'" drv)
+     (db-update-build-status! drv (build-status failed)
+                              #:log-file log))
     (('workers workers)
      (db-clear-workers)
      (for-each (lambda (worker)
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/remote-server.scm
index 3750b18..109f2d0 100644
--- a/src/cuirass/remote-server.scm
+++ b/src/cuirass/remote-server.scm
@@ -359,6 +359,8 @@ required and #f otherwise."
   (match (zmq-read-message message)
     (('build-succeeded _ ...)
      #t)
+    (('build-failed _ ...)
+     #t)
     (else #f)))
 
 (define* (run-fetch message #:key reply)
@@ -389,7 +391,12 @@ outputs are downloaded."
        (when (%cache-directory)
          (download-nar (%cache-directory) outputs url))
        (reply
-        (zmq-build-succeeded-message drv url log-file))))))
+        (zmq-build-succeeded-message drv url log-file))))
+    (('build-failed ('drv drv) ('url url) _ ...)
+     (let ((log-file
+            (download-log-file (%cache-directory) drv url)))
+       (reply
+        (zmq-build-failed-message drv url log-file))))))
 
 (define (start-fetch-worker name)
   "Start a fetch worker thread with the given NAME.  This worker takes care of
diff --git a/src/cuirass/remote-worker.scm b/src/cuirass/remote-worker.scm
index c496114..9c868b2 100644
--- a/src/cuirass/remote-worker.scm
+++ b/src/cuirass/remote-worker.scm
@@ -164,14 +164,15 @@ still be substituted."
         (guard (c ((store-protocol-error? c)
                    (info (G_ "Derivation `~a' build failed: ~a~%")
                          drv (store-protocol-error-message c))
-                   (reply (zmq-build-failed-message drv))))
+                   (reply (zmq-build-failed-message drv local-publish-url))))
           (if (build-derivations store (list drv))
               (begin
                 (info (G_ "Derivation ~a build succeeded.~%") drv)
                 (reply (zmq-build-succeeded-message drv local-publish-url)))
               (begin
                 (info (G_ "Derivation ~a build failed.~%") drv)
-                (reply (zmq-build-failed-message drv)))))))))
+                (reply
+                 (zmq-build-failed-message drv local-publish-url)))))))))
 
 (define* (run-command command server
                       #:key
diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
index 73481e2..8c83360 100644
--- a/src/cuirass/remote.scm
+++ b/src/cuirass/remote.scm
@@ -312,9 +312,9 @@ retries a call to PROC."
   "Return a message that indicates that the build of DRV has started."
   (format #f "~s" `(build-started (drv ,drv) (worker ,worker))))
 
-(define (zmq-build-failed-message drv)
+(define (zmq-build-failed-message drv url #:optional log)
   "Return a message that indicates that the build of DRV has failed."
-  (format #f "~s" `(build-failed (drv ,drv))))
+  (format #f "~s" `(build-failed (drv ,drv) (url ,url) (log ,log))))
 
 (define* (zmq-build-succeeded-message drv url #:optional log)
   "Return a message that indicates that the build of DRV is done."
@@ -396,8 +396,8 @@ received, return if no event occured for TIMEOUT 
milliseconds."
        (event-proc (list 'build-remote drv worker)))
       (('build-succeeded ('drv drv) ('url url) ('log log))
        (event-proc (list 'build-succeeded/log drv log)))
-      (('build-failed ('drv drv))
-       (event-proc (list 'build-failed drv)))
+      (('build-failed ('drv drv) ('url url) ('log log))
+       (event-proc (list 'build-failed/log drv log)))
       (('workers workers)
        (event-proc (list 'workers workers)))))