#!/bin/sh
#| -*- scheme -*-
exec csi -s $0 "$@"
|#

(use setup-download utils posix (srfi 1 13))

(define major-version     4)
(define chicken-install   (make-parameter "chicken-install"))
(define lib-dir           (make-pathname '("lib" "chicken") (->string major-version)))
(define repo-test-dir     (make-parameter (make-pathname (current-directory) "salmonella-repo")))
(define repo-test-lib-dir (make-parameter (make-pathname (repo-test-dir) lib-dir)))
(define chicken-eggs-dir  (make-parameter (make-pathname `(,(current-directory) "chicken-eggs" "release") 
							 (->string major-version))))
(define chicken-install-args (make-parameter (lambda () (string-append " -prefix " (repo-test-dir) " -t local "
								       " -l " (chicken-eggs-dir)))))


(define env-vars      (make-parameter
		       (string-append 
			"CHICKEN_INSTALL_PREFIX=" (repo-test-dir)
			" "
			"CHICKEN_INCLUDE_PATH=" (make-pathname (repo-test-dir) "share/chicken")
			" "
			"CHICKEN_REPOSITORY=" (repo-test-lib-dir) 
			)))
			
(define skip-eggs     (make-parameter '()))
(define verbose       (make-parameter #f))
(define logfile       (make-parameter "salmonella.log"))
(define system-deps   (make-parameter #f))
(define pkg-manager   (make-parameter #f))
(define resume        (make-parameter #f))
(define dont-ask      (make-parameter #f))
(define progress-file (make-parameter "salmonella.progress"))
(define html-output   (make-parameter "salmonella-report"))
(define css-file      (make-parameter #f))
(define ->html        (make-parameter #f))

(define (show . msg)
  (when (verbose)
    (print "  " (string-concatenate (map ->string msg)))))

(define egg-information (make-parameter (lambda () #f)))

(define eggs (make-parameter (lambda () #f)))

(define (system:system . command)
  ;; I'm afraid this thing won't work on windows...
  (let* ((p (open-input-pipe (sprintf "~A 2>&1" (string-concatenate command))))
         (output (read-all p)))
    (values (close-input-pipe p) output)))

(define (system:output . command)
  (let-values (((status output) (system:system (string-concatenate command))))
    output))

(define (system:status . command)
  (let-values (((status output) (system:system (string-concatenate command))))
    status))

(define usage #<#EOF
Usage: salmonella -h | -help | --help | -?
       salmonella <conf-file>
       salmonella <options>

<options> are Scheme expressions. <conf-file> is a file which may
contain the same Scheme expressions as <options>'s. The following
expressions are recognized:

             == Expression ==                   == Default ==
 (chicken-install \"<path to chicken-install>\")    chicken-install
 (chicken-install-args \"<args>\"                 a procedure which returns chicken-install options
 (env-vars \"<environment variables settings>\" CHICKEN_INCLUDE_PATH=(repo-test-lib-dir)
                                                CHICKEN_INSTALL_PREFIX=(repo-test-dir)
 (repo-test-dir \"<path to repo-test-dir>\")    `pwd`/salmonella-repo
 (chicken-eggs-dir \"<path to SVN dir>\")       `pwd`/chicken-eggs/release/4
 (skip-eggs (list \"egg1\" \"egg2\" ...))         '()
 (verbose <bool>)                               ##f
 (logfile \"filename\")                         salmonella.log
 (egg-information (lambda () ...))              a procedure which returns egg information for all eggs found in (chicken-eggs-dir)
 (eggs (lambda () ...))                         a procedure which returns the names of all eggs found in (chicken-eggs-dir)
 (system-deps \"filename\")                     ##f
 (pkg-manager \"system pkg manager & args\")    ##f
 (resume <bool>)                                ##f
 (dont-ask <bool>)                              ##f
 (progress-file \"filename\")                   salmonella.progress
 (dont-ask <bool>)                              ##f
 (progress-file \"filename\")                   salmonella.progress
 (html-output \"dirname\")                      salmonella-report.  If ##f, no HTML output
 (css-file \"filename\")                        ##f
 (->html \"filename\")                          ##f
Example:

 salmonella '(chicken-install \"/usr/local/chicken/bin/chicken-install\") (verbose ##t)'
EOF
)

(define (delete-path . paths)
  ;; mostly stolen from chicken-setup.scm
  (define *windows*
    (and (eq? (software-type) 'windows) 
         (build-platform) ) )

  (define *windows-shell* (memq *windows* '(msvc mingw32)))
  (let ((cmd (if *windows-shell* "del /Q /S" "rm -fr")))
    (for-each (lambda (path) (system* "~a ~a" cmd path)) paths)))

(define (clean-repo-test-dir)
  (delete-path (make-pathname (repo-test-dir) "*")))

(define (delete-eggs-source #!optional confirm)
  (when confirm
    (display (string-append "salmonella will delete all *.egg and *.egg-dir files and directories under "
                            (current-directory) ".  Proceed? [y/n]: "))
    (flush-output)
    (unless (string=? (read-line) "y")
      (print "Aborting.")
      (exit 0)))
  (delete-path (make-pathname (current-directory) "*.egg")
               (make-pathname (current-directory) "*.egg-dir")))

(define (install-egg egg)
  (system:system (sprintf "~a ~a ~a ~a" (env-vars) (chicken-install) ((chicken-install-args)) egg)))

(define (init-repo)
  (system:system (sprintf "~a ~a ~a" (chicken-install) "-init"  (repo-test-lib-dir))))

(define (report egg status msg #!key (action 'egg-install))
  (with-output-to-file (logfile)
    (lambda () (pp (list egg action status msg))) append:))

(define (set-installed egg)
  (with-output-to-file (progress-file) (cut print egg) append:))

(define (current-time) (seconds->string (current-seconds)))

(define (report-env)
  (when (logfile)
    (with-output-to-file (logfile)
      (lambda ()
        (pp #<#EOF
salmonella -- a tool for testing Chicken eggs (http://chicken.wiki.br/eggref/#(->string major-version)/salmonella)
#(string-trim-both (current-time))
#(system:output (chicken-install) " -version")
Options:
  chicken-install: #(chicken-install)
  repo-test-dir: #(repo-test-dir)
  chicken-install-args: #((chicken-install-args))
  env-vars: #(env-vars)
  skip-eggs:  #(skip-eggs)
  verbose: #(verbose)
  logfile: #(logfile)
  pkg-manager: #(pkg-manager)
  system-deps: #(system-deps)
  resume: #(resume)
  dont-ask: #(dont-ask)
  progress-file: #(progress-file)
  html-output: #(html-output)
  css-file: #(css-file)
  ->html: #(->html)
EOF
)))))

(define (install-system-deps egg dep-table)
  (let ((deps (assq (string->symbol egg) dep-table)))
    (when deps
      (for-each
       (lambda (dep)
         (show "Installing system dependency " dep)
         (let-values (((status output) (system:system (pkg-manager) egg)))
           (report egg status output action: 'osdep-install)))
       (map ->string (cdr deps))))))

(define (create-repo-test-dir)
  (if (not (file-exists? (repo-test-lib-dir)))
      (create-directory (repo-test-lib-dir) #t)))

(define egg-dependencies
  (let ((eggs/deps '()))
    (lambda arg
      (when (null? eggs/deps)
        (set! eggs/deps (map (lambda (egg-data)
                               (cons (car egg-data) (drop egg-data 3)))
                             ((egg-information)))))
      (if (null? arg)
          eggs/deps
          (let ((egg (car arg)))
            (alist-ref (if (string? egg)
                           (string->symbol egg)
                           egg)
                       eggs/deps))))))

(define (main)
  (let ((args (command-line-arguments)))
    
    ;; Check if user is asking for help
    (unless (null? args)
      (when (member (car args) '("-h" "-help" "--help" "-?"))
        (print usage)
        (exit 0)))
    
    ;; Eval command line options
    (if (and (not (null? args)) (file-exists? (car args)))
	(load (car args))
	(for-each eval (with-input-from-string (string-intersperse args) read-file)))

    (unless ((eggs))
      (eggs (lambda ()
              (show "Fetching eggs list...")
              (map (compose ->string car) ((egg-information))))))

    (unless ((egg-information)) 
      (egg-information 
       (let ((egg-data #f))
	 (lambda () (if (not egg-data)
			(begin 
			  (set! egg-data (gather-egg-information (chicken-eggs-dir)))
			  egg-data)
			egg-data)))))

    (when (->html)
      (logfile (->html))
      (report->html)
      (exit 0))
          
    (if (resume)
        (if (file-exists? (progress-file))
            (skip-eggs (append (skip-eggs) (read-lines (progress-file))))
            (begin
              (print "Could not find progress-file " (progress-file))
              (exit 1)))
        (when (file-exists? (progress-file))
          (delete-file (progress-file))))
    
    (clean-repo-test-dir)
    (create-repo-test-dir)
    (init-repo)
    
    (report-env)

    (delete-eggs-source (not (dont-ask)))
    
    (let ((deps (and (pkg-manager) (system-deps) (read-file (system-deps))))
	  (successful '())
	  (fail '()))
      (for-each (lambda (egg)
		  (unless (member egg (skip-eggs))
                    (install-system-deps egg deps)
                    (show "Deleting " egg " egg source (if it exists)...")
                    (delete-eggs-source)
                    (display (string-append "Installing " egg))
                    (flush-output)
                    (let-values (((status output) (install-egg egg)))
                      (print (string-pad
                              (cond ((zero? status)
				     (set! successful (cons egg successful))
				     "[ok]")
				    (else (set! fail (cons egg fail))
					  "[error]"))
                              (- 50 (string-length egg))))
                      (when (logfile) (report egg status output)))
                    (set-installed egg)
                    (show "Cleaning up " (repo-test-dir) "...")
                    (clean-repo-test-dir)
		    (create-repo-test-dir)
		    (init-repo)
		    ))
                ((eggs))))))

(define css-data
"body { font-size: 10pt; }
#egg-even { background-color: #CCC; }
#egg-fail { font-weight: bold; color: red; }
#egg-ok { font-weight: bold; color: blue; }
#egg-odd { background-color: #FFFFCC; }")
  
;;; A simple web-scheme replacement

(define s+ string-append)

(define (make-tag tagname)
  (lambda (data #!key (id #f))
    (conc "<" tagname (if id (conc " id=\"" id "\"") "") ">"
          data
          "</" tagname ">")))

(define (a url text)
  (s+ "<a 'href='" url "'>" text "</a>"))

(define p (make-tag 'p))
(define div (make-tag 'div))
(define pre (make-tag 'pre))
(define td (make-tag 'td))
(define tr (make-tag 'tr))
(define table (make-tag 'table))
(define b (make-tag 'b))
(define html (make-tag 'html))
(define body (make-tag 'body))
(define head (make-tag 'head))
(define title (make-tag 'title))
(define meta (make-tag 'meta))
(define style (make-tag 'style))
(define h1 (make-tag 'h1))
(define h2 (make-tag 'h2))
(define h3 (make-tag 'h3))

(define (ws:page contents #!key (css #f) (page-title ""))
  (html
   (s+ (head (s+ (title page-title)
                 (if css
                     (s+ "<link rel=stylesheet href='" css "' type=text/css>")
                     "")))
       (body contents))))

(define (tag-attribs->string attribs)
  (string-intersperse (map (lambda (attrib)
                             (conc (car attrib) "=\"" (cdr attrib) "\""))
                           attribs)
                      " "))

(define alternate-odd/even
  (let ((current #f))
    (lambda ()
      (set! current (not current))
      (if current
          'egg-even
          'egg-odd))))
    
(define (ws:make-table alist)
  (table (string-intersperse
          (map (lambda (line)
                 (tr (string-intersperse (map td line) "") id: (alternate-odd/even)))
               alist) "")))

(define (report->html)

  (define (link-egg-doc egg)
    (a (conc "http://chicken.wiki.br/eggref/" major-version "/" egg ".html")
       "egg page"))

  (define (link-egg-deps egg)
    (a (conc "http://chicken.wiki.br/dep-graphs/" egg ".png")
       "dependencies"))

  (define (egg-fail? egg eggs)
    (let ((egg-data (alist-ref (->string egg) eggs equal?)))
      ;; some eggs are not explicitly tested, so have no status
      (and egg-data (not (zero? (cadr egg-data))))))
          
  ;; if the optional argument FAIL is not #f, it indicates that all the EGGS failed
  (define (tabularize-eggs eggs css #!optional fail)
    (ws:make-table
     (append
      (list (map b (let ((h '("Egg" "Date" "Doc" "Dependencies")))
                     (if fail
                         (append h (list "Broken dependencies"))
                         h))))
      (map (lambda (egg-data)
             (let ((egg (car egg-data))
                   (status (caddr egg-data))
                   (output (cadddr egg-data)))
               ;; write the per-egg report
               (with-output-to-file (make-pathname (html-output) egg ".html")
                 (lambda ()
                   (print (ws:page (string-append (h1 egg) (pre output))
                                   css: css
                                   page-title: egg))))
               ;; generate the eggs table
	       (let ((version-str (lambda (egg-data)
				    (or (and egg-data (let ((x (alist-ref 'version egg-data)))
							(and x (car x)))) ""))))
               (map (lambda (info) (a (make-pathname '() egg ".html") info))
                    (let ((data
                           (list egg
                                 (let ((egg-data (alist-ref (string->symbol egg) ((egg-information)))))
				  (version-str egg-data))
                                 (link-egg-doc egg)
                                 (link-egg-deps egg))))
                      (if fail
                          (append data (list (string-intersperse
                                              (map link-egg-doc
                                                   (filter (lambda (egg)
                                                             (egg-fail? egg eggs))
                                                           (egg-dependencies egg)))
                                              ",")))
                          data))))))
           (sort eggs (lambda (s1 s2) (string< (car s1) (car s2))))))))

  (show "Generating HTML report")
  (when (file-exists? (html-output))
    (delete-path (html-output)))
  (create-directory (html-output))
  (let* ((data (with-input-from-file (logfile) read-file))
         (env-report (car data))
         (eggs-report (cdr data))
         (css (or (css-file)
                  (begin
                    (with-output-to-file (make-pathname (html-output) "salmonella.css")
                      (cut print css-data))
                    "salmonella.css"))))
    (with-output-to-file (make-pathname (html-output) "index.html")
      (lambda ()
        (print
         (ws:page
          (string-append
           (h1 "Salmonella report")
           (h2 "Summary")
           (let* ((success (filter (lambda (l) (zero? (caddr l))) eggs-report))
                  (fail (filter (lambda (l) (not (zero? (caddr l)))) eggs-report))
                  (success-count (length success))
                  (fail-count (length fail))
                  (total (+ (length eggs-report) (length (skip-eggs)))))
             (string-append
              (ws:make-table
               `(("Failed"   ,(div (number->string fail-count) id: "egg-fail"))
                 ("Succeed"  ,(div (number->string success-count) id: "egg-ok"))
                 ("Skipped"  ,(length (skip-eggs)))
                 (,(b "Total")    ,(b (number->string total)))))
              (h2 "Eggs")
              (h3 "Failed") (tabularize-eggs fail css 'fail)
              (h3 "Succeed") (tabularize-eggs success css)
              (if (null? (skip-eggs))
                  ""
                  (string-append
                   (h3 "Skipped")
                   (ws:make-table (append `((,(b "Egg"))) (map list (skip-eggs))))))))
           (h2 "Environment")
           (pre env-report)
           (p (conc "Finished at: " (current-time))))
          css: css
          page-title: "Salmonella report"))))))

(main)
(when (html-output) (report->html))