[no subject]

[Mathieu Othacehe]

branch: wip-offload
commit 393023070d96f7c64dacb942b23799b671612c86
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun Dec 13 13:32:20 2020 +0100

    tmp3
---
 src/cuirass/base.scm          |  8 ++++++--
 src/cuirass/http.scm          | 25 +++++--------------------
 src/cuirass/remote-server.scm | 19 +++++++++++++++----
 src/cuirass/remote.scm        |  8 ++++----
 4 files changed, 30 insertions(+), 30 deletions(-)

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 3a87fc3..fb62771 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -501,7 +501,7 @@ in the database."
   ;; Our shuffling algorithm is simple: we sort by .drv file name.  :-)
   (sort drv string<?))
 
-(define (set-build-successful! drv)
+(define* (set-build-successful! drv #:optional log)
   "Update the build status of DRV as successful and register any eventual
 build products."
   (let* ((build (db-get-build drv))
@@ -511,7 +511,8 @@ build products."
     (when (and spec build)
       (create-build-outputs build
                             (assq-ref spec #:build-outputs))))
-  (db-update-build-status! drv (build-status succeeded)))
+  (db-update-build-status! drv (build-status succeeded)
+                           #:log-file log))
 
 (define (update-build-statuses! store lst)
   "Update the build status of the derivations listed in LST, which have just
@@ -655,6 +656,9 @@ updating the database accordingly."
                                                #:entry-expiration
                                                gc-root-expiration-time))
          (log-message "bogus build-succeeded event for '~a'" drv)))
+    (('build-succeeded/log drv log)
+     (log-message "build succeeded: '~a'" drv)
+     (set-build-successful! drv log))
     (('build-failed drv _ ...)
      (if (valid? drv)
          (begin
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 60f1a75..5f203f5 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -447,26 +447,11 @@ Hydra format."
                           (#:link . ,(string-append "/jobset/" (assq-ref build 
#:specification)))))))
            (respond-build-not-found id))))
     (('GET "build" (= string->number id) "log" "raw")
-     (let ((build (and id (db-get-build id))))
-       (if build
-           (match (assq-ref build #:outputs)
-             (((_ (#:path . (? string? output))) _ ...)
-              ;; Redirect to a /log URL, which is assumed to be served
-              ;; by 'guix publish'.
-              (let ((uri (string->uri-reference
-                          (string-append "/log/"
-                                         (basename output)))))
-                (respond (build-response #:code 302
-                                         #:headers `((location . ,uri)))
-                         #:body "")))
-             (()
-              ;; Not entry for ID in the 'Outputs' table.
-              (respond-json-with-error
-               500
-               (format #f "Outputs of build ~a are unknown." id)))
-             (#f
-              (respond-build-not-found id)))
-           (respond-build-not-found id))))
+     (let* ((build (and id (db-get-build id)))
+            (log   (and build (assq-ref build #:log))))
+       (if (and log (file-exists? log))
+           (respond-gzipped-file log)
+           (respond-not-found log))))
     (('GET "output" id)
      (let ((output (db-get-output
                     (string-append (%store-prefix) "/" id))))
diff --git a/src/cuirass/remote-server.scm b/src/cuirass/remote-server.scm
index 0dcfed7..d233475 100644
--- a/src/cuirass/remote-server.scm
+++ b/src/cuirass/remote-server.scm
@@ -281,6 +281,9 @@ be used to reply to the worker."
   "Return the path of the NARINFO file for OUTPUT in CACHE-DIRECTORY."
   (string-append cache-directory "/" (basename output) ".narinfo"))
 
+(define (log-path cache-directory output)
+  (string-append cache-directory "/" (basename output) ".log"))
+
 (define* (sign-narinfo! narinfo)
   "Edit the given NARINFO file to replace the worker signature by the remote
 build server signature."
@@ -331,6 +334,11 @@ build server signature."
          (sign-narinfo! narinfo-file))))
    outputs))
 
+(define (download-log-file cache-directory derivation url)
+  (let ((url (string-append url "/log/" (basename derivation)))
+        (log-file (log-path cache-directory derivation)))
+    (and (url-fetch url log-file) log-file)))
+
 (define (add-to-store outputs url)
   "Add the OUTPUTS that are available from the substitute server at URL to the
 store."
@@ -344,7 +352,7 @@ store."
   "Return #t if the received MESSAGE implies that some output fetching is
 required and #f otherwise."
   (match (zmq-read-message message)
-    (('build-succeeded ('drv drv) ('url url))
+    (('build-succeeded _ ...)
      #t)
     (else #f)))
 
@@ -366,14 +374,17 @@ outputs are downloaded."
       (const '())))
 
   (match (zmq-read-message message)
-    (('build-succeeded ('drv drv) ('url url))
+    (('build-succeeded ('drv drv) ('url url) _ ...)
      (info (G_ "Fetching derivation ~a build outputs.~%") drv)
-     (let ((outputs (build-outputs drv)))
+     (let ((outputs (build-outputs drv))
+           (log-file
+            (download-log-file (%cache-directory) drv url)))
        (when (%add-to-store?)
          (add-to-store outputs url))
        (when (%cache-directory)
          (download-nar (%cache-directory) outputs url))
-       (reply message)))))
+       (reply
+        (zmq-build-succeeded-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.scm b/src/cuirass/remote.scm
index 216cdc4..6c5fb5b 100644
--- a/src/cuirass/remote.scm
+++ b/src/cuirass/remote.scm
@@ -245,9 +245,9 @@ retries a call to PROC."
   "Return a message that indicates that the build of DRV has failed."
   (format #f "~s" `(build-failed (drv ,drv))))
 
-(define (zmq-build-succeeded-message drv url)
+(define* (zmq-build-succeeded-message drv url #:optional log)
   "Return a message that indicates that the build of DRV is done."
-  (format #f "~s" `(build-succeeded (drv ,drv) (url ,url))))
+  (format #f "~s" `(build-succeeded (drv ,drv) (url ,url) (log ,log))))
 
 (define (zmq-worker-ping worker)
   "Return a message that indicates that WORKER is alive."
@@ -320,8 +320,8 @@ received, return if no event occured for TIMEOUT 
milliseconds."
       (('build-started ('drv drv) ('worker worker))
        (event-proc (list 'build-started drv))
        (event-proc (list 'build-remote drv worker)))
-      (('build-succeeded ('drv drv) ('url url))
-       (event-proc (list 'build-succeeded drv)))
+      (('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)))
       (('workers workers)