[no subject]

[Mathieu Othacehe]

branch: master
commit d909ca4500e5de64d9c9cb7d0f64cdaced41ec77
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sun May 30 09:43:58 2021 +0200

    remote-server: Display long fetch warning.
    
    * src/cuirass/scripts/remote-server.scm (run-fetch): Print a message if the
    fetch call took more than 60 seconds to complete.
---
 src/cuirass/scripts/remote-server.scm | 12 ++++++++++--
 1 file changed, 10 insertions(+), 2 deletions(-)

diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index 00af571..e8139be 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -51,7 +51,7 @@
   #:use-module (simple-zmq)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-  #:use-module ((srfi srfi-19) #:select (time-second))
+  #:use-module ((srfi srfi-19) #:select (time-second time-nanosecond))
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
@@ -346,7 +346,15 @@ directory."
     (('build-succeeded ('drv drv) ('url url) _ ...)
      (let ((outputs (build-outputs drv)))
        (log-message "fetching '~a' from ~a" drv url)
-       (add-to-store outputs url)
+       (call-with-time
+        (lambda ()
+          (add-to-store outputs url))
+        (lambda (time result)
+          (let ((duration (+ (time-second time)
+                             (/ (time-nanosecond time) 1e9))))
+            (when (> duration 60)
+              (log-message "fetching '~a' took ~a seconds."
+                           drv duration)))))
        (register-gc-roots drv)
 
        ;; Force the baking of the NAR substitutes so that the first client