;;
;; A driver program for continuous integration scripts.
;;
;; Copyright 2013 Ivan Raikov and the Okinawa Institute of Science and
;; Technology.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; .
;;
;;
(use data-structures posix files tcp srfi-1 srfi-13 regex setup-api
matchable uri-generic ersatz-lib)
(define v:quiet 0)
(define v:info 1)
(define v:debug 2)
(define ($ s) (if (symbol? s) s (string->symbol (->string s))))
(define verbose (make-parameter v:info))
(define prefix (make-parameter
(make-pathname (or (get-environment-variable "HOME") ".")
"testdrive")))
(define modules (make-parameter '()))
(define env (make-parameter '()))
(define (template-env)
(map (lambda (x)
(let ((k (string->symbol (->string (car x))))
(v (Tstr (->string (cdr x)))))
(cons k v)))
(env)))
(define (temp-path)
(make-parameter (or (get-environment-variable "TMPDIR")
(make-pathname (prefix) "/tmp"))))
(define (version-path)
(make-pathname (prefix) "module.versions"))
(define (manifest-path)
(make-pathname (prefix) "module.manifest"))
(define (output-location-prefix)
(make-pathname (prefix) "output"))
(define (build-location-prefix)
(make-pathname (prefix) "build"))
(define (scripts-location module-name)
(make-pathname (prefix) (sprintf "scripts/~A" module-name)))
(define (build-location module-name version)
(make-pathname (build-location-prefix)
(sprintf "~A.~A" module-name version)))
(define (process-lock-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-process-lock." module-name)
(->string version)) ))
(define (build-log-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-log." module-name)
(->string version)) ))
(define (build-lock-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-build-lock." module-name)
(->string version)) ))
(define (tests-lock-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-tests-lock." module-name)
(->string version)) ))
(define (tests-log-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-tests-log." module-name)
(->string version)) ))
(define (plots-lock-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-plots-lock." module-name)
(->string version)) ))
(define (plots-log-path module-name version)
(make-pathname (build-location module-name version)
(string-append (sprintf "~A-plots-log." module-name)
(->string version)) ))
(define (sed-quote str)
(let ((lst (string->list str)))
(let recur ((lst lst) (ax '()))
(if (null? lst) (list->string (reverse ax))
(let ((c (car lst)))
(if (char=? c #\/) (recur (cdr lst) (cons c (cons #\\ ax)))
(recur (cdr lst) (cons c ax))))
))))
(define (quotewrap str)
(cond ((quotewrapped? str) str)
((string-any char-whitespace? str)
(string-append "\"" str "\""))
(else str)))
(define (d fstr . args)
(if (= (verbose) v:debug)
(let ([port (current-output-port)])
(apply fprintf port fstr args)
(flush-output port) ) ))
(define (info fstr . args)
(if (>= (verbose) v:info)
(let ([port (current-output-port)])
(apply fprintf port fstr args)
(flush-output port) ) ))
(define (run:execute explist)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
(for-each (lambda (cmd)
(info " ~A~%~" cmd)
(system (->string cmd)))
(map smooth explist)))
(define (run:execute* explist)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
(for-each (lambda (cmd)
(info " ~A~%~" cmd)
(system* "~a" cmd))
(map smooth explist)))
(define-syntax run
(syntax-rules ()
((_ exp ...)
(run:execute* (list `exp ...)))))
(define-syntax run-
(syntax-rules ()
((_ exp ...)
(run:execute (list `exp ...)))))
(define (ipipe:execute lam cmd)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
((lambda (cmd)
(info " ~A~%~" cmd)
(call-with-input-pipe (sprintf "~a" cmd) lam))
(smooth cmd)))
(define-syntax ipipe
(syntax-rules ()
((_ lam exp)
(ipipe:execute lam `exp ))))
;; From spiffy
(define (link url label)
`(a (@ (href ,url)) ,label))
(define (call-with-input-file* file proc)
(call-with-input-file
file (lambda (p)
(handle-exceptions exn
(begin (close-input-port p) (signal exn))
(proc p)))))
(define (call-with-output-file* file proc)
(call-with-output-file
file (lambda (p)
(handle-exceptions exn
(begin (close-output-port p) (signal exn))
(proc p)))))
(define (template-script source-path target-path)
(if (and (file-exists? source-path) (not (file-exists? target-path)))
(begin
(run- (mkdir -p ,(pathname-directory target-path)))
(call-with-output-file target-path
(lambda (out)
(let ((source-file (pathname-strip-directory source-path))
(source-dir (pathname-directory source-path)))
(display (from-file source-file models: (template-env)
env: (template-std-env search-path: `(,source-dir))) out))))
(run (chmod u+x ,target-path))
)))
(define (revisions-command module-name config)
(or (alist-ref 'revision-command config)
(alist-ref 'revisions-command config)
(let ((config-dir (alist-ref 'config-path config)))
(if (not config-dir)
(error 'revisions-command "unable to find configuration directory of module"
module-name))
(let ((source-path (make-pathname config-dir "revisions")))
(if (not (file-exists? source-path))
(error 'revisions-command "unable to find revisions command of module"
module-name))
source-path)
))
)
(define (fetch-command module-name config)
(or (alist-ref 'fetch-command config)
(let ((config-dir (alist-ref 'config-path config)))
(if (not config-dir)
(error 'fetch-command "unable to find configuration directory of module"
module-name))
(let ((source-path (make-pathname config-dir "fetch"))
(target-path (make-pathname (scripts-location module-name) "fetch")))
(if (not (file-exists? source-path))
(error 'fetch-command "unable to find fetch command of module"
module-name))
(template-script source-path target-path)
target-path
))
))
(define (build-command module-name config)
(or (alist-ref 'build-command config)
(let ((config-dir (alist-ref 'config-path config)))
(if (not config-dir)
(error 'build-command "unable to find configuration directory of module"
module-name))
(let ((source-path (make-pathname config-dir "build"))
(target-path (make-pathname (scripts-location module-name) "build")))
(if (not (file-exists? source-path))
(error 'build-command "unable to find build command of module"
module-name))
(template-script source-path target-path)
target-path
))
))
(define (test-commands module-name config)
(or (alist-ref 'test-commands config)
(alist-ref 'test-command config)
(let ((config-dir (alist-ref 'config-path config)))
(if (not config-dir)
(error 'test-command "unable to find configuration directory of module"
module-name))
(if (file-exists? (make-pathname config-dir "tests"))
(let ((tests-run-path (make-pathname config-dir "tests/run")))
(let ((source-paths
(if (file-exists? tests-run-path)
(list tests-run-path)
(let ((flst (find-files (make-pathname config-dir "tests")
limit: 1
test: file-execute-access?)))
(sort flst string)
))
))
(let ((target-paths
(map (lambda (x)
(make-pathname (scripts-location module-name)
(pathname-strip-directory x)))
source-paths)))
(for-each template-script source-paths target-paths)
target-paths
))
))
))
)
(define (plot-commands module-name config)
(or (alist-ref 'plot-commands config)
(alist-ref 'plot-command config)
(let ((config-dir (alist-ref 'config-path config)))
(if (not config-dir)
(error 'plot-command "unable to find configuration directory of module"
module-name))
(let ((plots-run-path (make-pathname config-dir "plots")))
(let ((source-paths
(list plots-run-path)))
(let ((target-paths
(map (lambda (x)
(make-pathname (scripts-location module-name)
(pathname-strip-directory x)))
source-paths)))
(for-each template-script source-paths target-paths)
target-paths
))
))
))
(define (build module-name build-dir local-version version lock-file log-file fetch-cmd build-cmd )
(if (not (file-exists? lock-file))
(call-with-output-file* log-file
(lambda (out)
(run (mkdir -p ,build-dir))
(run (touch ,lock-file))
(if (or (not local-version) (not (string=? version local-version)))
(let ((manifest0 (find-files build-dir)))
(run- (,fetch-cmd ,module-name ,version ,build-dir >> ,log-file 2>&1 ))
(let ((manifest1 (find-files build-dir)))
(run- (,build-cmd ,module-name ,build-dir >> ,log-file 2>&1 ))
(let (
(versions (call-with-input-file* (version-path) read))
(manifests (call-with-input-file* (manifest-path) read))
(manifest (lset-difference string=? manifest1 manifest0))
)
(let ((versions1 (if (pair? versions)
(alist-update module-name version versions)
(list (cons module-name version))))
(manifests1 (if (pair? manifests)
(alist-update module-name manifest manifests)
(list (cons module-name manifest))))
)
(call-with-output-file* (version-path)
(lambda (out) (write versions1 out )))
(call-with-output-file* (manifest-path)
(lambda (out) (write manifests1 out )))
)
))
))
(run (rm ,lock-file))
))
))
(define (run-tests module-name build-dir version lock-file log-file cmds)
(if (not (file-exists? lock-file))
(call-with-output-file* log-file
(lambda (out)
(run (touch ,lock-file))
(for-each (lambda (cmd) (run- (,cmd ,module-name ,build-dir >> ,log-file 2>&1 ))) cmds)
(run (rm ,lock-file))
))
))
(define (make-plots module-name build-dir version lock-file log-file cmds)
(if (not (file-exists? lock-file))
(call-with-output-file* log-file
(lambda (out)
(run (touch ,lock-file))
(for-each (lambda (cmd) (run- (,cmd ,module-name ,build-dir >> ,log-file 2>&1 ))) cmds)
(run (rm ,lock-file))
))
))
(define (update-module module-name config)
(if (not (file-exists? (version-path)))
(let* ((path (version-path))
(dir (pathname-directory path)))
(run- (mkdir -p ,dir) (touch ,path))))
(if (not (file-exists? (manifest-path)))
(let* ((path (manifest-path))
(dir (pathname-directory path)))
(run- (mkdir -p ,dir) (touch ,path))))
(let ((versions (call-with-input-file* (version-path) read)))
(let (
(local-version
(and versions (pair? versions) (alist-ref module-name versions)))
(remote-version
(string-trim-both
(car
(let ((v (ipipe (lambda (x) (read-lines x)) (,(revisions-command module-name config) ,module-name))))
(if (null? v) (error 'update-module "cannot obtain version of module" module-name))
v))
))
)
(let ((loc (build-location module-name remote-version)))
(if (not (file-exists? loc))
(let ((build-lock-file (build-lock-path module-name remote-version))
(build-log-file (build-log-path module-name remote-version))
(test-lock-file (tests-lock-path module-name remote-version))
(test-log-file (tests-log-path module-name remote-version))
(plot-lock-file (plots-lock-path module-name remote-version))
(plot-log-file (plots-log-path module-name remote-version))
(process-lock-file (process-lock-path module-name remote-version))
)
(run (mkdir -p ,loc))
(run (touch ,build-log-file ,test-log-file ,plot-log-file ,process-lock-file))
(process-fork
(lambda ()
(handle-exceptions exn
(begin (run (rm ,process-lock-file)) (signal exn))
(begin
(build module-name loc local-version remote-version
build-lock-file build-log-file
(fetch-command module-name config)
(build-command module-name config))
(run-tests module-name loc remote-version
test-lock-file test-log-file
(test-commands module-name config))
(make-plots module-name loc remote-version
plot-lock-file plot-log-file
(plot-commands module-name config))
(run (rm ,process-lock-file))
(exit 0)
))
))
))
(list remote-version loc))
))
)
(define (modules-page modules manifests)
(let* (
(meta-data
(map
(lambda (kv)
(let* ((module-name (car kv))
(module-config (cdr kv))
(version.path (update-module module-name module-config))
(source-file (alist-ref module-name manifests))
)
(cons* `(version . ,(car version.path))
`(source . ,(link source-file
(pathname-strip-directory source-file)))
(alist-ref 'meta module-config))))
modules))
(meta-headers
(delete-duplicates
(fold (lambda (m ax) (fold (lambda (x ax) (cons ($ (car x)) ax)) ax m)) '() meta-data)
equal?
))
)
`(
(table
(tr . ,(map (lambda (x) `(th (b ,x))) (cons "Module" meta-headers)))
,(cadr
(fold
(lambda (kv module-meta ax)
(match-let (((i lst) ax))
(let* (
(module-name (car kv))
(module-config (cdr kv))
(module-label (alist-ref 'label module-config))
)
(list (+ 1 i)
(cons `(tr (@ (class ,(if (even? i) "even" "odd")))
(td ,(or module-label (sprintf "Module ~A" module-name))
" " ,(link (sprintf "module-log.html#~A" module-name) "(Logs)")
" " ,(link (sprintf "module-plot.html#~A" module-name) "(Plots)"))
. ,(map (lambda (mh) `(td ,(or (alist-ref mh module-meta) ""))) meta-headers))
lst))
)))
(list 0 '())
modules meta-data))
)
)
))
(define (module-log-page module-name module-config)
(let (
(module-label (alist-ref 'label module-config))
(version.path (update-module module-name module-config))
)
`((h1 ,(or module-label (sprintf "Module ~A" module-name )))
(a (@ (name ,(->string module-name))))
(p)
(p ,(sprintf "The current version of ~A is ~A.~%" module-name (car version.path)))
(p ,(link (sprintf "module-plot.html#~A" module-name) "Module plots"))
(p ,(link (sprintf "module-build-log.html#~A" module-name)
(sprintf "Module build log version ~A~%"
(car version.path))))
(p ,(link (sprintf "module-test-log.html#~A" module-name)
(sprintf "Module test log version ~A~%"
(car version.path))))
(p ,(link (sprintf "module-plot-log.html#~A" module-name)
(sprintf "Module plot log version ~A~%"
(car version.path))))
))
)
(define (copy-module-img-plots module-name module-loc module-dest)
(let ((jpgpat "(.*\\.[jJ][pP][eE]?[gG]$)")
(pngpat "(.*\\.[pP][nN][gG]$)")
(svgpat "(.*\\.[sS][vV][gG]$)")
)
(let ((pat (string-append jpgpat "|" pngpat "|" svgpat)))
(let ((flst (find-files module-loc test: (regexp pat))))
(for-each
(lambda (f)
(let ((fn (pathname-strip-directory f)))
(run (cp ,f ,(make-pathname module-dest fn)))))
flst)))
))
(define (module-img-plots module-name module-loc module-dest)
(let ((jpgpat "(.*\\.[jJ][pP][eE]?[gG]$)")
(pngpat "(.*\\.[pP][nN][gG]$)")
(svgpat "(.*\\.[sS][vV][gG]$)")
)
(let ((pat (string-append jpgpat "|" pngpat "|" svgpat)))
(let ((flst (find-files module-loc test: (regexp pat))))
(map (lambda (f)
(let ((fn (pathname-strip-directory f)))
`((a (@ (name ,(->string module-name))))
(p (img (@ (src ,(make-pathname
"figures"
(make-pathname (->string module-name) fn)))))))
))
flst)))
))
(define (module-plot-page module-name module-config output-dir)
(let* ((version.path (update-module module-name module-config))
(plot-file-path (cadr version.path))
(plot-file-dest (make-pathname output-dir (->string module-name))))
(module-img-plots module-name plot-file-path plot-file-dest))
)
(define (copy-module-plots module-name module-config output-dir)
(let* ((version.path (update-module module-name module-config))
(plot-file-path (cadr version.path))
(plot-file-dest (make-pathname output-dir (->string module-name))))
(copy-module-img-plots module-name plot-file-path plot-file-dest))
)
(define (module-source-page module-name module-config module-manifest output-dir)
(let* ((version.path (update-module module-name module-config))
(source-file-dest (make-pathname output-dir (->string module-name))))
(map (lambda (f)
(let ((fn (pathname-strip-directory f)))
`((a (@ (name ,(->string module-name))))
(p ,(sprintf "Sources for module ~A:" module-name))
(p ,(link f "Download file"))
(pre . ,(intersperse (read-lines f) "\n")))
))
module-manifest)
))
(define (copy-module-sources module-name module-manifest module-dest)
(for-each
(lambda (f)
(let ((fn (pathname-strip-directory f)))
(run (cp ,f ,(make-pathname module-dest fn)))))
module-manifest))
(define (module-build-log-page module-name module-config)
(let ((version.path (update-module module-name module-config)))
`((a (@ (name ,(->string module-name))))
(p ,(sprintf "Build log for module ~A:" module-name))
(pre . ,(intersperse (read-lines (build-log-path module-name (car version.path))) "\n")))
)
)
(define (module-test-log-page module-name module-config)
(let ((version.path (update-module module-name module-config)))
`((a (@ (name ,(->string module-name))))
(p ,(sprintf "Test log for module ~A:" module-name))
(pre . ,(intersperse (read-lines (tests-log-path module-name (car version.path))) "\n")))
)
)
(define (module-plot-log-page module-name module-config)
(let ((version.path (update-module module-name module-config)))
`((a (@ (name ,(->string module-name))))
(p ,(sprintf "Plot log for module ~A:" module-name))
(pre . ,(intersperse (read-lines (plots-log-path module-name (car version.path))) "\n")))
)
)
(define (neat-date d)
(time->string (seconds->utc-time d) "%Y-%m-%d"))
(define default-layout
'((xhtml-1.0-strict)
(html
(head
(link (@ (href "site.css") (rel "stylesheet") (type "text/css")))
(title ,($ 'title)))
(body
(h1 ,($ 'title))
(div (@ (id "content")) (inject ,contents))))))
(define site-css
#<string module-name)))
(module-sources-dir (make-pathname figures-dir (->string module-name)))
(manifests (call-with-input-file* (manifest-path) read))
(module-manifest (alist-ref module-name manifests))
)
(run (mkdir -p ,module-figures-dir))
(copy-module-plots module-name module-config figures-dir)
(copy-module-sources module-name module-manifest sxml-dir)
(match-let (((source-page log-page plot-page build-log-page test-log-page plot-log-page )
module-pages))
(list
(cons (module-source-page module-name module-config module-manifest html-dir) source-page)
(cons (module-log-page module-name module-config) log-page)
(cons (module-plot-page module-name module-config figures-dir) plot-page)
(cons (module-build-log-page module-name module-config) build-log-page)
(cons (module-test-log-page module-name module-config) test-log-page)
(cons (module-plot-log-page module-name module-config) plot-log-page)
)
))
)
))
))
'(() () () () () ())
(modules)))
)
(run (mkdir -p ,report-dir)
(mkdir -p ,layouts-dir)
(mkdir -p ,sxml-dir)
(mkdir -p ,figures-dir)
(mkdir -p ,html-dir)
(touch ,(make-pathname report-dir "hyde.scm"))
)
(call-with-output-file
(make-pathname css-dir "site.css")
(lambda (out)
(display site-css out)
))
(call-with-output-file
(make-pathname layouts-dir "default.sxml")
(lambda (out)
(pp '() out)
(display "`" out)
(pp default-layout out)
))
(let* ((manifests (call-with-input-file* (manifest-path) read))
(output-manifests (map (lambda (x)
(let ((module-name (car x)))
(let ((fn (if (null? (cdr (cdr x)))
(pathname-strip-directory (car (cdr x)))
(sprintf "~A.tgz" module-name))))
(cons module-name (make-pathname html-dir fn)))
))
manifests)))
(call-with-output-file
(make-pathname sxml-dir "index.sxml")
(lambda (out)
(pp `((title "Testdrive module list")) out)
(display "'" out)
(pp (modules-page (modules) output-manifests) out)
))
)
(match-let (((source-page log-page plot-page build-log-page test-log-page plot-log-page )
module-pages))
;; output module pages
(call-with-output-file
(make-pathname sxml-dir "module-log.sxml")
(lambda (out)
(pp `((title "Testdrive module logs")) out)
(display "'" out)
(pp log-page out)
))
(call-with-output-file
(make-pathname sxml-dir "module-plot.sxml")
(lambda (out)
(pp `((title "Testdrive module plots")) out)
(display "'" out)
(pp plot-page out)
))
(call-with-output-file
(make-pathname sxml-dir "module-build-log.sxml")
(lambda (out)
(pp `((title "Testdrive module build logs")) out)
(display "'" out)
(pp build-log-page out)
))
(call-with-output-file
(make-pathname sxml-dir "module-test-log.sxml")
(lambda (out)
(pp `((title "Testdrive module test logs")) out)
(display "'" out)
(pp test-log-page out)
))
(call-with-output-file
(make-pathname sxml-dir "module-plot-log.sxml")
(lambda (out)
(pp `((title "Testdrive module plot logs")) out)
(display "'" out)
(pp plot-log-page out)
))
))
))
(main (command-line-arguments))