06/11: offload: 'status' reports the time difference.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 02ec889e6b8f6593dd90afcb4d60a43ea67be4b8
Author: Ludovic Courtès <address@hidden>
Date:   Tue Jan 22 17:37:59 2019 +0100

    offload: 'status' reports the time difference.
    
    * guix/scripts/offload.scm (check-machine-status): Report the time
    difference for each MACHINE.
---
 guix/scripts/offload.scm | 37 +++++++++++++++++++++++++------------
 1 file changed, 25 insertions(+), 12 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 2116b38..eb02672 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -712,18 +712,31 @@ machine."
                    (warning (G_ "failed to run 'guix repl' on machine '~a'~%")
                             (build-machine-name machine)))
                   ((? inferior? inferior)
-                   (let ((uts  (inferior-eval '(uname) inferior))
-                         (load (node-load inferior))
-                         (free (node-free-disk-space inferior)))
-                     (close-inferior inferior)
-                     (format #t "~a~%  kernel: ~a ~a~%  architecture: ~a~%\
-  host name: ~a~%  normalized load: ~a~%  free disk space: ~,2f MiB~%"
-                             (build-machine-name machine)
-                             (utsname:sysname uts) (utsname:release uts)
-                             (utsname:machine uts)
-                             (utsname:nodename uts)
-                             (normalized-load machine load)
-                             (/ free (expt 2 20) 1.)))))
+                   (let ((now (car (gettimeofday))))
+                     (match (inferior-eval '(list (uname)
+                                                  (car (gettimeofday)))
+                                           inferior)
+                       ((uts time)
+                        (when (< time now)
+                          ;; Build machine clocks must not be behind as this
+                          ;; could cause timestamp issues.
+                          (warning (G_ "machine '~a' is ~a seconds behind~%")
+                                   (build-machine-name machine)
+                                   (- now time)))
+
+                        (let ((load (node-load inferior))
+                              (free (node-free-disk-space inferior)))
+                          (close-inferior inferior)
+                          (format #t "~a~%  kernel: ~a ~a~%  architecture: 
~a~%\
+  host name: ~a~%  normalized load: ~a~%  free disk space: ~,2f MiB~%\
+  time difference: ~a s~%"
+                                  (build-machine-name machine)
+                                  (utsname:sysname uts) (utsname:release uts)
+                                  (utsname:machine uts)
+                                  (utsname:nodename uts)
+                                  (normalized-load machine load)
+                                  (/ free (expt 2 20) 1.)
+                                  (- time now))))))))
 
                 (disconnect! session))
               machines)))