From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Sun, 16 Jul 2017 20:31:40 +0000 (-0700)
Subject: devops: Fixes, a hostname parameter for devops:build-status.
X-Git-Tag: mit-scheme-pucked-9.2.12~106
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b33debb2268cf25b41af1cd8cd7aaf53217f29cb;p=mit-scheme.git

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 2711677af..e1f7e865c 100644
--- 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.
 
 ;;;; 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)