From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 25 May 2017 00:33:38 +0000 (-0700)
Subject: devops: Myriad fixes and additions.  Build docs for binary tarballz.
X-Git-Tag: mit-scheme-pucked-9.2.12~121
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=65d1c6b88e6f44a82561d09568d10ba3b327e6e9;p=mit-scheme.git

devops: Myriad fixes and additions.  Build docs for binary tarballz.

Set umask before installing.  Add run-noerror for debugging.  Fix
plugin-dirt? filter.  Change sorted-tags to return the newest version
first.  Replaced ubuntu? slot with an OS name string.  Reimplement
host-ubuntu?.  Add host-ubuntu-codename.
---

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 35314319e..45147c217 100644
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -106,6 +106,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (run "cd "pkgdir"/src && ./configure --enable-native-code="sarch)
     (run "cd "pkgdir"/src && make")
     (run "cd "pkgdir"/src/microcode && make distclean")
+    (run "cd "pkgdir"/doc && ./configure")
+    (run "cd "pkgdir"/doc && make")
     (run "chmod -R go-w "pkgdir)
     (run "cd "build-dir" && tar czf "name"-"vers"-"sarch".tar.gz "name"-"vers)
     (run "chmod 444 "pkgdir"-"sarch".tar.gz")
@@ -113,10 +115,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (run "cd "build-dir" && tar xzf "name"-"vers"-"sarch".tar.gz")
     (run "cd "pkgdir"/src && ./configure")
     (run "cd "pkgdir"/src && make compile-microcode")
-    (run "cd "pkgdir"/src && make install")
+    (run "cd "pkgdir"/src && umask 022 && make install")
     (run "cd "pkgdir"/doc && ./configure")
-    (run "cd "pkgdir"/doc && make install-info install-html install-pdf")
-    (run "rm -rf "pkgdir)))
+    (run "cd "pkgdir"/doc && umask 022"
+	 " && make install-info install-html install-pdf")))
 
 (define (build-core-dpkg name vers)
   (let ((pkgdir (string build-dir"/"name"-"vers)))
@@ -138,7 +140,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
      (lambda ()
        (run "cd "pkgdir" && ./configure")
        (run "cd "pkgdir" && make all check")
-       (run "cd "pkgdir" && make install install-html install-pdf")))
+       (run "cd "pkgdir" && umask 022"
+	    " && make install install-html install-pdf")))
     (run "rm -rf "pkgdir)))
 
 (define (build-plugin-dpkg name vers)
@@ -266,6 +269,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (log cmdln"\n")
     (shell* cmdln)))
 
+(define (run-noerror . strings)
+  (let ((cmdln (apply string strings)))
+    (log cmdln"\n")
+    (shell*-noerror cmdln)))
+
 (define (shell-lines . strings)
   (call-with-input-string (shell-output (apply string strings)) read-lines))
 
@@ -303,9 +311,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (let ((status (apply run-shell-command cmdln
 		       'environment scheme-subprocess-environment
 		       options)))
-       (if (not (zero? status))
-	   (error "Shell command failed:" status cmdln))
-       status))
+    (if (not (zero? status))
+	(error "Shell command failed:" status cmdln))
+    status))
+
+(define (shell*-noerror cmdln . options)
+  (apply run-shell-command cmdln 'environment scheme-subprocess-environment
+	 options))
 
 (define (with-subprocess-environment-variable name value thunk)
   (let* ((outside scheme-subprocess-environment)
diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index b1ad3d931..b2caa00c7 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -92,7 +92,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (plugin-lint plugin changed dirt)
   (let ((version (plugin-version plugin))
 	(dversion (debian-version (plugin-directory plugin)))
-	(released (released-version (plugin-project-name plugin))))
+	(released (released-version (plugin-package plugin))))
     (append
      (dirt->plugin-lint plugin dirt)
      (debian-version-lint version dversion)
@@ -124,12 +124,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (list (string "Debian version ("dversion") does not match."))
        '())))
 
-(define (released-version-lint version released changed)
+(define (released-version-lint version-string released changed)
   (cond ((eq? #f released)
 	 (list "First release!"))
 	((and (not (null? changed))
-	      (not (version<? (->version released)
-			      (->version version))))
+	      (not (version>? (->version version-string) released)))
 	 (list "Version is out-of-date."))
 	(else
 	 '())))
@@ -160,8 +159,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (let* ((dir (plugin-directory plugin))
 	 (dir-len (string-length dir))
 	 (dir-end (fix:+ 3 dir-len)))
-    (and (fix:>= line-len dir-end)
-	 (string=? dir (substring line 3 dir-end)))))
+    (and (fix:> line-len dir-end)
+	 (string=? dir (substring line 3 dir-end))
+	 (char=? #\/ (string-ref line dir-end)))))
 
 (load-option 'regular-expression)
 
@@ -180,13 +180,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		  (loop))))))))
 
 (define (released-version name)
-  (let* ((tags (sorted-tags name))
-	 (last-tag (and (pair? tags)
-			(cdar tags)))
-	 (regs (and last-tag
-		    (re-string-match (string name"-\\([0-9.]+\\)$") last-tag))))
-    (and regs
-	 (re-match-extract last-tag regs 1))))
+  (let ((tags (sorted-tags name)))
+    (and (pair? tags)
+	 (caar tags))))
 
 (define (core-changed-files)
   (let ((hash (released-hash (project-name))))
@@ -210,10 +206,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (call-with-input-file (string (plugin-directory plugin)"/configure.ac")
     (lambda (in)
       (let loop ()
-	(let* ((line (read-line in))
-	       (regs (and (string? line)
-			  (re-string-match "^AC_INIT" line))))
-	  (if regs
+	(let ((line (read-line in)))
+	  (if (and (string? line)
+		   (string-prefix? "AC_INIT" line))
 	      (let* ((line (read-line in))
 		     (regs (and (string? line)
 				(re-string-match "[ \t]*[[]\\([0-9.]+\\)[]]"
@@ -226,7 +221,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		  (loop))))))))
 
 (define (plugin-changed-files plugin)
-  (let ((hash (released-hash (plugin-project-name plugin))))
+  (let ((hash (released-hash (plugin-package plugin))))
     (and hash
 	 (let ((dir (plugin-directory plugin)))
 	   (filter (lambda (filename)
@@ -262,86 +257,84 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(error "no changed files"))
     (let* ((version (core-version))
 	   (project (project-name))
-	   (pkg (string project"-"version))
+	   (pkgvers (string project"-"version))
 	   ;;(topdir (car (shell-lines "/bin/pwd")))
 	   (lint (core-lint version changed dirt)))
-      (log "# "pkg":\n")
+      (log "# "pkgvers":\n")
       (write-lint lint)
       (write-changed-files changed)
-      (run "mkdir devops/"pkg)
+      (run "mkdir devops/"pkgvers)
       (if snap?
 	  (run "git archive --prefix="project"/ HEAD"
-	       " | ( cd devops/"pkg" && tar xf - )")
+	       " | ( cd devops/"pkgvers" && tar xf - )")
 	  (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
 		(datime
 		 (universal-time->local-time-string (get-universal-time))))
-	    (run "git tag -s -m \""datime" "hash"\" "pkg)
-	    (run "git archive --prefix="project"/ "pkg
-		 " | ( cd devops/"pkg" && tar xf - )")))
-      (run "cd devops/"pkg" && "project"/dist/make-src-files standard")
-      (run "chmod 444 devops/"pkg"/"pkg".tar.gz")
-      (run "mv devops/"pkg"/"pkg".tar.gz devops/")
-      (run "rm -rf devops/"pkg)
-      (run "cd devops/ && tar xzf "pkg".tar.gz")
-      (run "cd devops/ && dpkg-source --build "pkg)
+	    (run "git tag -s -m \""datime" "hash"\" "pkgvers)
+	    (run "git archive --prefix="project"/ "pkgvers
+		 " | ( cd devops/"pkgvers" && tar xf - )")))
+      (run "cd devops/"pkgvers" && "project"/dist/make-src-files standard")
+      (run "mv devops/"pkgvers"/"pkgvers".tar.gz devops/")
+      (run "rm -rf devops/"pkgvers)
+      (run "cd devops/ && tar xzf "pkgvers".tar.gz")
+      (run "cd devops/ && dpkg-source --build "pkgvers)
       (run "chmod 444 devops/"project"_"version".dsc")
       (run "chmod 444 devops/"project"_"version".tar.xz")
-      (run "rm -rf devops/"pkg))))
+      (run "rm -rf devops/"pkgvers))))
 
 (define (release-plugin plugin dirt snap?)
   (let ((changed (plugin-changed-files plugin))
-	(pkg (plugin-package-name plugin))
+	(pkgvers (plugin-package/version plugin))
 	(dir (plugin-directory plugin)))
     (if (and (null? changed) (not snap?))
 	(error "no changed files"))
     (let ((lint (plugin-lint plugin changed dirt))
-	  (logfile (string "devops/"pkg"-src.log")))
-      (log "# "pkg":\n")
+	  (logfile (string "devops/"pkgvers"-src.log")))
+      (log "# "pkgvers":\n")
       (write-lint lint)
       (write-changed-files changed)
       (with-output-log
        logfile
        (lambda ()
 	 (if snap?
-	     (run "git archive --prefix="pkg"/ HEAD -- "dir
+	     (run "git archive --prefix="pkgvers"/ HEAD -- "dir
 		  " | ( cd devops && tar xf - )")
 	     (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
 		   (datime
 		    (universal-time->local-time-string (get-universal-time))))
-	       (run "git tag -s -m \""datime" "hash"\" "pkg)
-	       (run "git archive --prefix="pkg"/ "pkg" -- "dir
+	       (run "git tag -s -m \""datime" "hash"\" "pkgvers)
+	       (run "git archive --prefix="pkgvers"/ "pkgvers" -- "dir
 		    " | ( cd devops && tar xf - )")))
-	 (run "cd devops/"pkg"/"dir" && ./autogen.sh")
-	 (run "cd devops/"pkg"/"dir" && ./configure")
-	 (run "cd devops/"pkg"/"dir" && make dist")
-	 (run "mv devops/"pkg"/"dir"/"pkg".tar.gz devops/")
-	 (run "chmod 444 devops/"pkg".tar.gz")
-	 (run "rm -rf devops/"pkg)
-	 (let ((name (plugin-project-name plugin))
+	 (run "cd devops/"pkgvers"/"dir" && ./autogen.sh")
+	 (run "cd devops/"pkgvers"/"dir" && ./configure")
+	 (run "cd devops/"pkgvers"/"dir" && make dist")
+	 (run "mv devops/"pkgvers"/"dir"/"pkgvers".tar.gz devops/")
+	 (run "chmod 444 devops/"pkgvers".tar.gz")
+	 (run "rm -rf devops/"pkgvers)
+	 (let ((name (plugin-package plugin))
 	       (vers (plugin-version plugin)))
-	   (run "cd devops/ && tar xzf "pkg".tar.gz")
-	   (run "cd devops/ && dpkg-source --build "pkg)
+	   (run "cd devops/ && tar xzf "pkgvers".tar.gz")
+	   (run "cd devops/ && dpkg-source --build "pkgvers)
 	   (run "chmod 444 devops/"name"_"vers".dsc")
 	   (run "chmod 444 devops/"name"_"vers".tar.xz")
-	   (run "rm -rf devops/"pkg))))
+	   (run "rm -rf devops/"pkgvers))))
       (delete-file logfile))))
 
 (define (snapshot-core dirt)
   (let ((changed (or (core-changed-files) '()))
 	(version (core-version))
-	(released-version (released-version (project-name))))
+	(released (released-version (project-name))))
     (let ((new (->version version))
-	  (old (->version released-version))
 	  (source-filename
 	   (string "devops/"(project-name)"-"version".tar.gz")))
       (define (found) (log "# "source-filename":\nAlready done.\n"))
       (cond ((and (null? changed)
-		  (version=? old new))
+		  (version=? new released))
 	     (if (file-exists? source-filename)
 		 (found)
 		 (release-core dirt #t)))
 	    ((and (pair? changed)
-		  (version<? old new))
+		  (version>? new released))
 	     ;; Clobber!
 	     (release-core dirt #t))
 	    ((null? changed)
@@ -354,20 +347,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (snapshot-plugin plugin dirt)
   (let ((changed (or (plugin-changed-files plugin) '()))
 	(version (plugin-version plugin))
-	(released-version (released-version (plugin-project-name plugin))))
+	(released (released-version (plugin-package plugin))))
     (let ((new (->version version))
-	  (old (->version released-version))
 	  (source-filename
-	   (string "devops/"
-		   (plugin-project-name plugin)"-"version".tar.gz")))
+	   (string "devops/"(plugin-package plugin)"-"version".tar.gz")))
       (define (found) (log "# "source-filename":\nAlready done.\n"))
       (cond ((and (null? changed)
-		  (version=? old new))
+		  (version=? new released))
 	     (if (file-exists? source-filename)
 		 (found)
 		 (release-plugin plugin dirt #t)))
 	    ((and (pair? changed)
-		  (version<? old new))
+		  (version>? new released))
 	     ;; Clobber!
 	     (release-plugin plugin dirt #t))
 	    ((null? changed)
@@ -416,7 +407,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	 (lambda (src)
 	   (let ((name (car src))
 		 (vers (cdr src)))
-
 	     (if (not (member (string name"-"vers".tar.gz") files))
 		 (run "scp -p devops/"name"-"vers".tar.gz"
 		      " "(host-login/dir host))
@@ -504,7 +494,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		 (set! project-name ,(project-name))
 		 (set! build-dir ,(host-directory host))
 		 (set! build-scheme-architecture
-		       ,(host-scheme-architecture host))
+		       ',(host-scheme-architecture host))
 		 (set! build-debian-architecture
 		       ,(host-debian-architecture host))
 		 (set! build-ubuntu?
@@ -528,7 +518,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(error "wrong Debian architecture"))))
 
 (define (verify-host-ubuntu-ness host i/o)
-  (write-line '(if (ubuntu?) "yes" "no") i/o)
+  (write-line '(write-line (if (ubuntu?) "yes" "no")) i/o)
   (flush-output i/o)
   (let ((str (read-until 3000 i/o)))
     (if (not (string? str))
@@ -562,16 +552,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	      (if (and proc (memq (subprocess-status proc) '(running stopped)))
 		  (ignore-errors (lambda () (subprocess-kill proc))))))))))))
 
-(define (read-lines-until match usec in)
+(define (read-lines-until line usec in)
   (do-until
    (lambda ()
      (let loop ((lines '()))
-       (let ((line (read-line in)))
-	 (if (eof-object? line)
+       (let ((line* (read-line in)))
+	 (if (eof-object? line*)
 	     (reverse! lines)
-	     (if (string=? match line)
-		 (reverse! (cons line lines))
-		 (loop (cons line lines)))))))
+	     (if (string=? line line*)
+		 (reverse! (cons line* lines))
+		 (loop (cons line* lines)))))))
    usec
    (lambda () #f)))
 
@@ -604,11 +594,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define project-name-string "new-scheme")
 
-(define (plugin-project-name plugin)
+(define (plugin-package plugin)
   (string (project-name)"-"(plugin-name plugin)))
 
-(define (plugin-package-name plugin)
-  (string (plugin-project-name plugin)"-"(plugin-version plugin)))
+(define (plugin-package/version plugin)
+  (string (plugin-package plugin)"-"(plugin-version plugin)))
 
 (define (plugin name directory)
   (let ((duplicate (find (lambda (p) (string=? name (plugin-name p)))
@@ -630,14 +620,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (name plugin-name)
   (directory plugin-directory))
 
-(define (host name user directory sarch darch ubuntu?)
+(define (host name user directory sarch darch os)
   (let ((duplicate (find (lambda (h) (string=? name (host-name h)))
 			 host-list)))
     (if duplicate
 	(error (string "Host "name" already defined."))))
   (set! host-list
 	(append! host-list
-		 (list (make-host name user directory sarch darch ubuntu?))))
+		 (list (make-host name user directory sarch darch os))))
   unspecific)
 
 (define (hosts) (list-copy host-list))
@@ -655,14 +645,35 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	n)))
 
 (define-record-type <host>
-    (make-host name user directory sarch darch ubuntu?)
+    (make-host name user directory sarch darch os)
     host?
   (name host-name)
   (user host-user)
   (directory host-directory)
   (sarch host-scheme-architecture)
   (darch host-debian-architecture)
-  (ubuntu? host-ubuntu?))
+  (os host-os))
+
+(define (host-ubuntu? host)
+  (os-ubuntu? (host-os host)))
+
+(define (host-ubuntu-codename host)
+  (ubuntu-os-codename (host-os host)))
+
+(define (os-ubuntu? os)
+  (string-prefix? "Ubuntu " os))
+
+(define (ubuntu-os-codename os)
+  (cond ((string=? "Ubuntu 17.04" os) "zesty")
+	((string=? "Ubuntu 16.10" os) "yakkety")
+	((string=? "Ubuntu 16.04" os) "xenial")
+	(else (error "Unexpected Ubuntu OS:" os))))
+
+(define (ubuntu-os-version os)
+  (cond ((string=? "Ubuntu 17.04" os) "17.04")
+	((string=? "Ubuntu 16.10" os) "16.10")
+	((string=? "Ubuntu 16.04" os) "16.04")
+	(else (error "Unexpected Ubuntu OS:" os))))
 
 ;;;; Misc
 
@@ -675,7 +686,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 			     line)
 		       (error "Bogus line from git tag:" line))))
 	       (shell-lines "git tag -l '"package-name"-*'")))
-	(lambda (a b) (version<? (car a) (car b)))))
+	(lambda (a b) (version>? (car a) (car b)))))
+
+(define (version-comparator < >)
+  (named-lambda (version-compare v1 v2)
+    (cond ((eq? #f v1)
+	   #t)
+	  ((eq? #f v2)
+	   #f)
+	  ((null? v2)
+	   #f)
+	  ((null? v1) ;; and (pair? v2)
+	   #t)
+	  ((< (car v1) (car v2))
+	   #t)
+	  ((> (car v1) (car v2))
+	   #f)
+	  (else
+	   (version<? (cdr v1) (cdr v2))))))
 
 (define (->version string)
   (and string
@@ -683,21 +711,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define version=? equal?)
 
-(define (version<? v1 v2)
-  (cond ((eq? #f v1)
-	 #t)
-	((eq? #f v2)
-	 #f)
-	((null? v2)
-	 #f)
-	((null? v1) ;; and (pair? v2)
-	 #t)
-	((< (car v1) (car v2))
-	 #t)
-	((> (car v1) (car v2))
-	 #f)
-	(else
-	 (version<? (cdr v1) (cdr v2)))))
+(define (version-string version)
+  (if (pair? version)
+      (decorated-string-append "" "." ""
+       (map (lambda (num) (number->string num 10))
+	    version))
+      (error "Bad version:" version)))
+
+(define version=? equal?)
+(define version<? (version-comparator < >))
+(define version>? (version-comparator > <))
 
 (define (read-first-line filename)
   (call-with-input-file filename