01/10: offload: Honor the build timeout internally.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a708de151c255712071e42e5c8284756b51768cd
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jun 11 11:42:59 2018 +0200

    offload: Honor the build timeout internally.
    
    * guix/scripts/offload.scm (call-with-timeout): New procedure.
    (with-timeout): New macro.
    (process-request): Use it around 'transfer-and-offload' call.
---
 guix/scripts/offload.scm | 46 ++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 38 insertions(+), 8 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 56d6de6..fb61d7c 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -494,6 +494,30 @@ slot (which must later be released with 
'release-build-slot'), or #f and #f."
         (()
          (values #f #f))))))
 
+(define (call-with-timeout timeout drv thunk)
+  "Call THUNK and leave after TIMEOUT seconds.  If TIMEOUT is #f, simply call
+THUNK.  Use DRV as an indication of what we were building when the timeout
+expired."
+  (if (number? timeout)
+      (dynamic-wind
+        (lambda ()
+          (sigaction SIGALRM
+            (lambda _
+              ;; The exit code here will be 1, which guix-daemon will
+              ;; interpret as a transient failure.
+              (leave (G_ "timeout expired while offloading '~a'~%")
+                     (derivation-file-name drv))))
+          (alarm timeout))
+        thunk
+        (lambda ()
+          (alarm 0)))
+      (thunk)))
+
+(define-syntax-rule (with-timeout timeout drv exp ...)
+  "Evaluate EXP... and leave after TIMEOUT seconds if EXP hasn't completed.
+If TIMEOUT is #f, simply evaluate EXP..."
+  (call-with-timeout timeout drv (lambda () exp ...)))
+
 (define* (process-request wants-local? system drv features
                           #:key
                           print-build-trace? (max-silent-time 3600)
@@ -520,13 +544,18 @@ slot (which must later be released with 
'release-build-slot'), or #f and #f."
                  (display "# accept\n")
                  (let ((inputs  (string-tokenize (read-line)))
                        (outputs (string-tokenize (read-line))))
-                   (transfer-and-offload drv machine
-                                         #:inputs inputs
-                                         #:outputs outputs
-                                         #:max-silent-time max-silent-time
-                                         #:build-timeout build-timeout
-                                         #:print-build-trace?
-                                         print-build-trace?)))
+                   ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can
+                   ;; be issues with the connection or deadlocks that could
+                   ;; lead the 'guix offload' process to remain stuck forever.
+                   ;; To avoid that, install a timeout here as well.
+                   (with-timeout build-timeout drv
+                     (transfer-and-offload drv machine
+                                           #:inputs inputs
+                                           #:outputs outputs
+                                           #:max-silent-time max-silent-time
+                                           #:build-timeout build-timeout
+                                           #:print-build-trace?
+                                           print-build-trace?))))
                (lambda ()
                  (release-build-slot slot)))
 
@@ -755,6 +784,7 @@ This tool is meant to be used internally by 
'guix-daemon'.\n"))
 ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
 ;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
 ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
+;;; eval: (put 'with-timeout 'scheme-indent-function 2)
 ;;; End:
 
 ;;; offload.scm ends here