(use matchable data-structures posix files tcp srfi-1 regex setup-api uri-generic awful sendfile)
(require-library spiffy intarweb)
(import (only spiffy current-request current-response write-logged-response 
	      with-headers mime-type-map root-path file-extension->mime-type)
	(only intarweb response-port request-method  request-headers
	      header-values header-value etag-matches? response-has-message-body-for-request?
	      ))

(enable-sxml #t)


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

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

(define http-user-agent "build-model")

(define home (get-environment-variable "HOME"))

(define version-file
  (make-parameter (make-pathname home "/build/model.versions") ))
  
(define build-location-prefix 
  (make-parameter (make-pathname home "/build/model") ))

(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 "~A-log." model-name version)) )

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

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

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

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

(define (plots-log-path model-name version) 
  (make-pathname (build-location model-name version) 
		 (string-append "plots-log." version)) )

(debug-file (make-pathname build-location-prefix "/debug.log"))
;;(error-log (make-pathname build-location-prefix "/debug.log"))


(define config-path
 (let ((args (command-line-arguments)))
   (if (null? args) (error 'model-ci "missing config path argument")
       (car args))))


(define models (make-parameter '()))

(load config-path)


(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)
     (with-input-from-pipe (sprintf "~a" cmd) lam))
   (smooth cmd)))


(define-syntax ipipe
  (syntax-rules ()
    ((_ lam exp)
     (ipipe:execute lam `exp ))))


;; From spiffy
(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 (revisions-command model-name config)
  (or (lookup-def 'revision-command config)
      (lookup-def 'revisions-command config)
      (let ((config-dir (lookup-def 'config-dir config)))
	(if (not config-dir)
	    (error 'revisions-command "unable to find model revisions command"))
	(make-pathname config-dir "revisions"))))


(define (fetch-command model-name config)
  (or (lookup-def 'fetch-command config)
      (lookup-def 'fetch-command config)
      (let ((config-dir (lookup-def 'config-dir config)))
	(if (not config-dir)
	    (error 'fetch-command "unable to find model fetch command"))
	(make-pathname config-dir "fetch"))))


(define (build-command model-name config)
  (or (lookup-def 'build-command config)
      (lookup-def 'build-command config)
      (let ((config-dir (lookup-def 'config-dir config)))
	(if (not config-dir)
	    (error 'fetch-command "unable to find model build command"))
	(make-pathname config-dir "build"))))


(define (test-commands model-name config)
  (or (lookup-def 'test-commands config)
      (lookup-def 'test-command config)
      (let ((config-dir (lookup-def 'config-dir config)))
	(if (not config-dir)
	    (error 'fetch-command "unable to find model test commands"))
	(let ((flst (find-files (make-pathname config-dir "tests") 
				limit: 1
				test: file-execute-access?)))
	  (sort flst string<?)))))


(define (plot-commands model-name config)
  (or (lookup-def 'plot-commands config)
      (lookup-def 'plot-command config)
      (let ((config-dir (lookup-def 'config-dir config)))
	(if (not config-dir)
	    (error 'fetch-command "unable to find model plot commands"))
	(make-pathname config-dir "plots"))))


(define (build model-name build-dir local-version version lock-file log-file fetch-cmd build-cmd )
  (if (not (file-exists? lock-file))
      (with-output-to-file log-file
	(run (mkdir -p ,build-dir))
	(run (touch ,lock-file))
	(if (not (string=? version local-version))
	    (if (zero? (run- (,fetch-cmd ,model-name ,version ,build-dir  )
			     (,build-cmd ,model-name ,build-dir )))
		(let ((versions (read (version-file))))
		  (call-with-output-file version-file
		    (alist-update model-name version versions))
		  ))
	    )
	(run (rm ,lock-file))
	)))


(define (run-tests model-name build-dir version lock-file log-file cmds)
  (if (not (file-exists? lock-file))
      (with-output-to-file log-file
	(run (touch ,lock-file))
	(for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file)))
		  cmds)
	(run (rm ,lock-file))
	)))


(define (make-plots model-name build-dir version lock-file log-file cmds)
  (if (not (file-exists? lock-file))
      (with-output-to-file log-file
	(run (touch ,lock-file))
	(for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file)))
		  cmds)
	(run (rm ,lock-file))
	)))


(define (update-model model-name config)
  (let ((versions (read (version-file))))
    (let ((local-version (car (alist-ref model-name versions)))
	  (remote-version (car (string-split (ipipe (lambda (x) x) (,(revisions-command config))) "\n"))))
      (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 () 
			      (build model-name loc local-version remote-version 
				     build-lock-file build-log-file
				     (fetch-command config)
				     (build-command config))
			      (run-tests model-name loc remote-version 
					 test-lock-file test-log-file
					 (test-commands config))
			      (make-plots model-name loc remote-version 
					 plot-lock-file plot-log-file
					 (plot-commands config))
			      ))
	      ))
	(list remote-version loc))
      )))

	
(define-page "/models"
  (lambda ()
    (map 
     (lambda (kv)
       (let* ((model-name (car v))
	      (model-config-dir (cdr v)))
	 `(link ,(sprintf "/model-status?name=~A" model-name)
		,(sprintf "Model ~A" model-name))))
     (models))))

	
(define-page "/model-status"
  (lambda ()
    (let* ((model-name ($ 'name))
	   (model-config (alist-ref model-name (models))))
      (if (not model-config)
	  `(p "Invalid model name" ,model-name)
	  (let ((version.path (update-model model-name model-config))
		(sys (system-information)))
	    (cond ((file-exists? (build-lock-path model-name (car version.path)))
		   `(p "Build in progress, try again later."))
		  ((file-exists? (tests-lock-path model-name (car version.path)))
		   `(p "Tests in progress, try again later."))
		  ((file-exists? (plots-lock-path model-name (car version.path)))
		   `(p "Plots in progress, try again later."))
		  (else
		   `((h1 ,(sprintf "Model ~A" model-name ))
		     (p)
		     (p ,(sprintf "The current version of ~A is ~A.~%" model-name (car version.path)))
		     (p ,(link ,(sprintf "/model-build-log?name=~A" model-name)
			       (sprintf "Model build log version ~A~%" 
					(car version.path))))
		     (p ,(link ,(sprintf "/model-test-log?name=~A" model-name)
			       (sprintf "Model test log version ~A~%" 
					(car version.path))))
		     (p ,(link ,(sprintf "/model-plot-log?name=~A" model-name)
			       (sprintf "Model plot log version ~A~%" 
					(car version.path))))
		     ))
		))
	  ))
    ))
	


(define-page "/model-build-log"
  (lambda () 
    (let* ((model-name ($ 'name))
	   (model-config (alist-ref model-name (models))))
      (if (not model-config)
	  `(p "Invalid model name" ,model-name)
	  (let ((version.path (update-model  model-name model-config)))
	    `(pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n"))
	    ))
      )))
    

(define-page "/reload"
  (lambda ()
    (reload-apps (awful-apps))
    (load config-path)
    "Reloaded"))