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 35314319eea11206c93945cf04570c730392fff0..45147c217c4d1006f9ac769edcf8378d4ad4e8be 100644 (file)
--- 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 b1ad3d9317ebabff5a1a0da4baeb039b5586373a..b2caa00c78a7c69831a70238c4020c82fc3c31ef 100644 (file)
--- 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))))
 \f
 ;;;; 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