;;
;; Continuous integration scripts for model development.
;;

(use matchable data-structures posix files tcp srfi-1 srfi-13 regex setup-api uri-generic ersatz-lib)


(define v:quiet 0)
(define v:info  1)
(define v:debug 2)


(define verbose (make-parameter v:info))

(define prefix (make-parameter (or (get-environment-variable "HOME") ".")))

(define tmpdir (make-parameter (or (get-environment-variable "TMPDIR") "/tmp")))

(define models (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 (version-path)
  (make-pathname (prefix) "/build/model-ci.versions"))
  
(define (output-location-prefix)
  (make-pathname (prefix) "/build/model-ci-output"))
  
(define (build-location-prefix)
  (make-pathname (prefix) "/build/model-ci"))

(define (scripts-location model-name) 
  (make-pathname (tmpdir) (sprintf "~A" model-name)))

(define (build-location model-name version) 
  (make-pathname (build-location-prefix) 
		 (sprintf "~A.~A" model-name version)))

(define (build-log-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-log." model-name) 
				(->string version)) ))

(define (build-lock-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-build-lock." model-name)
				(->string version)) ))

(define (tests-lock-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-tests-lock." model-name)
				(->string version)) ))

(define (tests-log-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-tests-log." model-name)
				(->string version)) ))

(define (plots-lock-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-plots-lock." model-name)
				(->string version)) ))

(define (plots-log-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append (sprintf "~A-plots-log." model-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) (raise 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) (raise exn))
		(proc p)))))


(define (template-script source-path target-path)
  (if (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 model-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 model revisions command"))
        (let ((source-path (make-pathname config-dir "revisions")))
          (if (not (file-exists? source-path))
              (error 'revisions-command "unable to find model revisions command"))
          source-path)
        ))
      )


(define (fetch-command model-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 model fetch command"))
	(let ((source-path (make-pathname config-dir "fetch"))
              (target-path (make-pathname (scripts-location model-name) "fetch")))
          (if (not (file-exists? source-path))
              (error 'fetch-command "unable to find model fetch command"))
          (template-script source-path target-path)
          target-path
        ))
  ))


(define (build-command model-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 model build command"))
	(let ((source-path (make-pathname config-dir "build"))
              (target-path (make-pathname (scripts-location model-name) "build")))
          (if (not (file-exists? source-path))
              (error 'build-command "unable to find model build command"))
          (template-script source-path target-path)
          target-path
        ))
  ))


(define (test-commands model-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 model test commands"))
	(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 model-name) 
                                          (pathname-strip-directory x)))
                        source-paths)))
              (for-each template-script source-paths target-paths)
              target-paths
              ))
          ))
      ))


(define (plot-commands model-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 model plot commands"))
	(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 model-name) 
                                          (pathname-strip-directory x)))
                        source-paths)))
              (for-each template-script source-paths target-paths)
              target-paths
              ))
          ))
      ))


(define (build model-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)))
	      (begin
		(run- (,fetch-cmd ,model-name ,version ,build-dir >> ,log-file 2>&1  )
		      (,build-cmd ,model-name ,build-dir >> ,log-file 2>&1 ))
		(let ((versions (call-with-input-file* (version-path) read)))
		  (let ((versions1 (if (pair? versions) 
				       (alist-update model-name version versions)
				       (list (cons model-name version)))))
		    (call-with-output-file* (version-path)
					    (lambda (out) (write versions1 out ))))
		  )))
	  (run (rm ,lock-file))
	  ))
      ))


(define (run-tests model-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 ,model-name ,build-dir >> ,log-file  2>&1  ))) cmds)
	  (run (rm ,lock-file))
	  ))
      ))


(define (make-plots model-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 ,model-name ,build-dir >> ,log-file  2>&1  ))) cmds)
	  (run (rm ,lock-file))
	  ))
      ))


(define (update-model model-name config)

  (if (not (file-exists? (version-path)))
      (let* ((path (version-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 model-name versions)))
	  (remote-version
           (string-trim-both
            (car (ipipe (lambda (x) (read-lines x)) (,(revisions-command model-name config) ,model-name))))))

      

      (let ((loc (build-location model-name remote-version)))
	(if (not (file-exists? loc))
	    (let ((build-lock-file (build-lock-path model-name remote-version))
		  (build-log-file (build-log-path model-name remote-version))
		  (test-lock-file (tests-lock-path model-name remote-version))
		  (test-log-file  (tests-log-path model-name remote-version))
		  (plot-lock-file (plots-lock-path model-name remote-version))
		  (plot-log-file  (plots-log-path model-name remote-version))
		  )
	      (process-fork
	       (lambda ()
		 (run (mkdir -p ,loc))
		 (run (touch ,build-log-file  ,test-log-file ,plot-log-file))
		 (build model-name loc local-version remote-version 
			build-lock-file build-log-file
			(fetch-command model-name config)
			(build-command model-name config))
		 (run-tests model-name loc remote-version 
			    test-lock-file test-log-file
			    (test-commands model-name config))
		 (make-plots model-name loc remote-version 
			     plot-lock-file plot-log-file
			     (plot-commands model-name config))
		 (exit 0)
		 ))
	      ))
	(list remote-version loc))
      )))


(define (models-page models)
  `(
    (ul .
        ,(map 
          (lambda (kv)
            (let* (
                   (model-name (car kv))
                   (model-config (cdr kv))
                   (model-label (alist-ref 'label model-config))
                   )
              
              `(li ,(link (sprintf "model-status.html#~A" model-name)
                          (or model-label (sprintf "Model ~A" model-name))))
              ))
          models)
        )
    )
  )
   

(define (model-status-page model-name model-config)
  (let (
        (model-label  (alist-ref 'label model-config))
        (version.path (update-model model-name model-config))
        )
    `((h1 ,(or model-label (sprintf "Model ~A" model-name )))
      (a (@ (name ,(or model-label model-name))))
      (p)
      (p ,(sprintf "The current version of ~A is ~A.~%" model-name (car version.path)))
      (p ,(link (sprintf "model-plot.html#~A" model-name) "Model plots"))
      (p ,(link (sprintf "model-build-log.html#~A" model-name)
               (sprintf "Model build log version ~A~%" 
                         (car version.path))))
      (p ,(link (sprintf "model-test-log.html#~A" model-name)
                (sprintf "Model test log version ~A~%" 
                         (car version.path))))
      (p ,(link (sprintf "model-plot-log.html#~A" model-name)
                (sprintf "Model plot log version ~A~%" 
                         (car version.path))))
      ))
  )

	

   
(define (copy-model-img-plots model-name model-loc model-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 model-loc test: (regexp pat))))
        (for-each
         (lambda (f)
           (let ((fn (pathname-strip-directory f)))
             (run (cp ,f  ,(make-pathname model-dest fn)))))
         flst)))
    ))

   
(define (model-img-plots model-name model-loc model-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 model-loc test: (regexp pat))))
	(map (lambda (f) 
	       (let ((fn (pathname-strip-directory f)))
		 `(p (img (@ (src ,(make-pathname model-dest fn)))))
		 )) 
             flst)))
    ))


(define (model-plot-page model-name model-config output-dir)
   (let* ((version.path (update-model model-name model-config))
          (plot-file-path (cadr version.path))
          (plot-file-dest (make-pathname output-dir (->string model-name))))
     (model-img-plots model-name plot-file-path plot-file-dest))
   )

(define (copy-model-plots model-name model-config output-dir)
   (let* ((version.path (update-model model-name model-config))
          (plot-file-path (cadr version.path))
          (plot-file-dest (make-pathname output-dir (->string model-name))))
     (copy-model-img-plots model-name plot-file-path plot-file-dest))
   )

   
(define (model-build-log-page model-name model-config)
   (let ((version.path (update-model  model-name model-config)))
     `((p "Build log:")
       (pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n")))
     )
  )

   
(define (model-test-log-page model-name model-config)
  (let ((version.path (update-model model-name model-config)))
    `((p "Test log:")
      (pre . ,(intersperse (read-lines (tests-log-path model-name (car version.path))) "\n")))
    )
  )

   
(define (model-plot-log-page model-name model-config)
  (let ((version.path (update-model  model-name model-config)))
    `((p "Plot log:")
      (pre . ,(intersperse (read-lines (plots-log-path model-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 (main args)

  (let ((config-path
         (let ((path (get-environment-variable "MODEL_CI_CONFIG")))
           (or path (and (pair? args) (car args))))))

    (load config-path)

    (let* ((report-dir 
            (make-pathname (output-location-prefix)
                           (neat-date (current-seconds))))
           (layouts-dir 
            (make-pathname report-dir
                           "layouts"))
           (sxml-dir 
            (make-pathname report-dir
                           "src"))
           (figures-dir 
            (make-pathname sxml-dir
                           "figures"))
           (html-dir 
            (make-pathname report-dir
                           "out"))
           (model-pages
            (fold 
             (lambda (kv ax)
               (let* (
                      (model-name (car kv))
                      (model-config (cdr kv))
                      (model-label (alist-ref 'label model-config))
                      )
                 (let recur ((version.path (update-model model-name model-config))
                             (model-pages ax))
                   
                   (cond ((file-exists? (build-lock-path model-name (car version.path)))
                          (recur version.path model-pages))
                         ((file-exists? (tests-lock-path model-name (car version.path)))
                          (recur version.path model-pages))
                         ((file-exists? (plots-lock-path model-name (car version.path)))
                          (recur version.path model-pages))
                         (else
                          (let ((model-figures-dir (make-pathname figures-dir (->string model-name))))
                            (run (mkdir -p ,model-figures-dir))
                            (copy-model-plots model-name model-config figures-dir)
                            (match-let (((status-page plot-page build-log-page test-log-page plot-log-page ) model-pages))
                                       (list
                                        (cons (model-status-page model-name model-config) status-page)
                                        (cons (model-plot-page model-name model-config figures-dir) plot-page)
                                        (cons (model-build-log-page model-name model-config) build-log-page)
                                        (cons (model-test-log-page model-name model-config) test-log-page)
                                        (cons (model-plot-log-page model-name model-config) plot-log-page)
                                        )
                                       ))
                          )
                         ))
                 ))
             '(() () () () ())
             (models)))
           )
      
      (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 layouts-dir "default.sxml")
        (lambda (out)
          (pp '() out)
          (display "`" out) 
          (pp default-layout out)
          ))
      
      (call-with-output-file
          (make-pathname sxml-dir "index.sxml")
        (lambda (out)
          (pp `((title "NEMO model list")) out)
          (display "'" out) 
          (pp (models-page (models)) out)
          ))
      
      (match-let (((status-page plot-page build-log-page test-log-page plot-log-page ) model-pages))
                 ;; output model pages
                 
                 (call-with-output-file
                     (make-pathname sxml-dir "model-status.sxml")
                   (lambda (out)
                     (pp `((title "NEMO model status")) out)
                     (display "'" out) 
                     (pp status-page out)
                     ))
                 
                 (call-with-output-file
                     (make-pathname sxml-dir "model-plot.sxml")
                   (lambda (out)
                     (pp `((title "NEMO model plots")) out)
                     (display "'" out) 
                     (pp plot-page out)
                     ))
                 
                 (call-with-output-file
                     (make-pathname sxml-dir "model-build-log.sxml")
                   (lambda (out)
                     (pp `((title "NEMO model build logs")) out)
                     (display "'" out) 
                     (pp build-log-page out)
                     ))
                 
                 (call-with-output-file
                     (make-pathname sxml-dir "model-test-log.sxml")
                   (lambda (out)
                     (pp `((title "NEMO model test logs")) out)
                     (display "'" out) 
                     (pp test-log-page out)
                     ))
                 
                 (call-with-output-file
                     (make-pathname sxml-dir "model-plot-log.sxml")
                   (lambda (out)
                     (pp `((title "NEMO model plot logs")) out)
                     (display "'" out) 
                     (pp plot-log-page out)
                     ))
                 
                 ))
    ))

(main (command-line-arguments))