devops: Fixes, a hostname parameter for devops:build-status.

Added a read-reply procedure that should, eventually, detect error
messages from the build host.  For now, use everywhere to simplify
requests/replies.  Use it to check for the existence of the build
directory.  Fix sorted-tags and use the latest regsexps (requiring 9.3
or a pucked 9.2).

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 2711677af41e226b19f1cd04781cb8fafabbe96c..e1f7e865c5853b130c53e234dec643ca250a21c4 100644 (file)
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -370,38 +370,62 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 \f
 ;;;; Build Status
 
-(define (devops:build-status)
+(define (devops:build-status #!optional hostname)
   (let ((srcs (available-sources "devops"))
        (hosts (hosts)))
     (if (null? hosts)
        (error "No build hosts defined.")
-       (for-each (lambda (host) (write-host-status host srcs))
-                 hosts))))
+       (if (default-object? hostname)
+           (for-each (lambda (host) (write-host-status host srcs))
+                     hosts)
+           (let* ((name
+                   (cond ((string? hostname) hostname)
+                         ((symbol? hostname) (symbol->string hostname))
+                         (else (error "Hostname is not a symbol or string:"
+                                      hostname))))
+                  (host (find (lambda (host)
+                                (string=? name (host-name host)))
+                              hosts)))
+             (if host
+                 (write-host-status host srcs)
+                 (error "Build host not found:" hostname)))))))
 
 (define build-dir "devops")
 
+(define (read-reply query i/o)
+  (write-line `(write-line ,query) i/o)
+  (flush-output-port i/o)
+  (let ((object (read-until 3000 i/o)))
+    (if (eq? object 'timeout)
+       (error "Timeout awaiting reply."))
+    object))
+
 (define (write-host-status host srcs)
   (log "# "(host-name host)":\n")
   (call-with-host-i/o
    host
    (lambda (i/o)
-     (write-line '(write-line (quote ready)) i/o)
-     (flush-output i/o)
-     (let ((lines (read-lines-until "ready" 5000 i/o)))
-       (cond ((eq? #f lines)
-             (error "not responding"))
-            ((not (equal? "ready" (last lines)))
-             (for-each (lambda (line) (log line"\n")) lines)
-             (error "not ready"))))
-     (write-line `(write-line (directory-file-names ,(host-directory host) #f))
-                i/o)
-     (flush-output i/o)
-     (let ((files (read-until 3000 i/o))
+     (let ((reply (read-reply '(quote ready) i/o)))
+       (if (not (eq? reply 'ready))
+          (error "not ready:" reply)))
+     (let ((reply (read-reply `(let ((dirname ,(host-directory host)))
+                                (if (and (file-exists? dirname)
+                                         (file-directory? dirname))
+                                    'yes
+                                    'no))
+                             i/o)))
+       (cond ((eq? reply 'yes)
+             unspecific)
+            ((eq? reply 'no)
+             (error "no build directory:" (host-directory host)))
+            (else (error "unexpected reply:" reply))))
+     (let ((files (read-reply `(directory-file-names ,(host-directory host) #f)
+                             i/o))
           (proj (project-name))
           (sarch (host-scheme-architecture host))
           (darch (host-debian-architecture host)))
-       (if (eq? #f files)
-          (error "not OK"))
+       (if (not (list-of-type? files string?))
+          (error "unexpected filename list:" files))
        (write-lock-report host i/o files)
        (for-each
         (lambda (src)
@@ -431,12 +455,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (if (member "lock" files)
       (let* ((lockfile (string (host-directory host)"/lock"))
             (start-time
-             (begin
-               (write-line `(write-line (file-time->local-time-string
-                                         (file-modification-time ,lockfile)))
-                           i/o)
-               (flush-output i/o)
-               (read-until 3000 i/o))))
+             (read-reply `(file-time->local-time-string
+                           (file-modification-time ,lockfile))
+                         i/o)))
        (log "Daemon started "start-time"\n"))
       (log "No daemon running.\n")))
 
@@ -461,14 +482,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
               (string (host-directory host)"/"elogfile) i/o))))))
 
 (define (write-minutes-stalled elogpath i/o)
-  (let ((min (begin
-              (write-line
-               `(write-line (- (get-universal-time)
-                               (file-time->universal-time
-                                (file-modification-time ,elogpath))))
-               i/o)
-              (flush-output i/o)
-              (quotient (read-until 3000 i/o) 60))))
+  (let* ((sec (read-reply `(- (get-universal-time)
+                             (file-time->universal-time
+                              (file-modification-time ,elogpath)))
+                         i/o))
+        (min (quotient sec 60)))
     (cond ((> min 60)
           (log "    No progress in over an hour!\n"))
          ((> min 10)
@@ -501,26 +519,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                       ,(host-ubuntu? host))
                 (build))
              i/o)
-  (flush-output i/o)
-  (let ((lines (read-lines-until "OK" 3000 i/o)))
-    (if (not lines)
+  (flush-output-port i/o)
+  (let ((reply (read-reply '(quote ok) i/o)))
+    (if (not (eq? reply 'ok))
        (error "not OK")))
   (close-input-port i/o)
   (close-output-port i/o))
 
 (define (verify-host-debian-architecture host i/o)
-  (write-line '(debian-architecture) i/o)
-  (flush-output i/o)
-  (let ((darch (read-until 3000 i/o)))
+  (let ((darch (read-reply '(debian-architecture) i/o)))
     (if (not (string? darch))
        (error "no Debian architecture"))
     (if (not (string=? darch (host-debian-architecture host)))
        (error "wrong Debian architecture"))))
 
 (define (verify-host-ubuntu-ness host i/o)
-  (write-line '(write-line (if (ubuntu?) "yes" "no")) i/o)
-  (flush-output i/o)
-  (let ((str (read-until 3000 i/o)))
+  (let ((str (read-reply '(if (ubuntu?) "yes" "no") i/o)))
     (if (not (string? str))
        (error "no Ubuntu-ness"))
     (let ((ubu? (string=? "yes" str)))
@@ -678,16 +692,27 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 ;;;; Misc
 
 (define (sorted-tags package-name)
-  (sort (let ((pattern (string package-name"-\\(.*\\)$")))
-         (map (lambda (line)
-                (let ((regs (re-string-match pattern line)))
-                  (if regs
-                      (cons (->version (re-match-extract line regs 1))
-                            line)
-                      (error "Bogus line from git tag:" line))))
-              (shell-lines "git tag -l '"package-name"-*'")))
+  (sort (let ((pattern (compile-regsexp
+                       `(seq ,package-name #\-
+                             (group version
+                                    (+ (alt #\. (char-in ,char-set:numeric))))
+                             (string-end)))))
+         (append-map!
+          (lambda (line)
+            (let ((match (regsexp-match-string pattern line)))
+              (if match
+                  (list (cons (->version (match-extract match 'version))
+                              line))
+                  '())))
+          (shell-lines "git tag -l '"package-name"-*'")))
        (lambda (a b) (version>? (car a) (car b)))))
 
+(define (match-extract match key)
+  (let ((entry (assq key (cddr match))))
+    (if entry
+       (cdr entry)
+       (error "Match key not found:" key match))))
+
 (define (version-comparator < >)
   (named-lambda (version-compare v1 v2)
     (cond ((eq? #f v1)