From 65d1c6b88e6f44a82561d09568d10ba3b327e6e9 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 24 May 2017 17:33:38 -0700 Subject: [PATCH] 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. --- src/devops/build.scm | 26 ++++-- src/devops/devops.scm | 203 +++++++++++++++++++++++------------------- 2 files changed, 132 insertions(+), 97 deletions(-) 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 (versionversion 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? 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? 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 - (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))))) + +(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 + (versionversion string) (and string @@ -683,21 +711,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define version=? equal?) -(define (version (car v1) (car v2)) - #f) - (else - (versionstring num 10)) + version)) + (error "Bad version:" version))) + +(define version=? equal?) +(define version)) +(define version>? (version-comparator > <)) (define (read-first-line filename) (call-with-input-file filename -- 2.25.1