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

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

(define major-version     4)
(define binary-version    5)
(define csi               (make-parameter "csi"))
(define chicken-install   (make-parameter "chicken-install"))
(define lib-dir           (make-pathname '("lib" "chicken") (->string binary-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 base-uri      (make-parameter "/"))
(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 dep-graphs-dir (make-parameter (make-pathname (html-output) "dep-graphs")))
(define dep-graphs-webdir (make-parameter "dep-graphs"))
(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 ==
 (csi            \"<path to csi>\")                 csi
 (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
 (dep-graphs-dir \"dirname\")                   (html-output)/dep-graphs
 (dep-graphs-webdir \"dirname\")                dep-graphs
 (css-file \"filename\")                        ##f
 (->html \"filename\")                          ##f
 (base-uri \"uri\")                             /
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 (egg-extension-information egg)
  (system:system (sprintf "~a ~a -e \"(print (extension-information '~a))\"" (env-vars) (csi) egg )))

(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)
                 (egg-install-info '()))
  (with-output-to-file (logfile)
    (lambda () (pp (list egg action status msg egg-install-info)))
    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://wiki.call-cc.org/egg/salmonella)
Started on #(string-trim-both (current-time))
Chicken version: #(system:output (chicken-install) " -version")
Options:
  csi: #(csi)
  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)
  dep-graphs-dir: #(dep-graphs-dir)
  dep-graphs-webdir: #(dep-graphs-webdir)
  css-file: #(css-file)
  ->html: #(->html)
  base-uri: #(base-uri)
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-info
  (let ((info '()))
    (lambda args
      (when (null? info)
        (set! info (map (lambda (egg-data)
                          (cons (car egg-data) (drop egg-data 3)))
                        ((egg-information)))))
      (if (null? args)
          info
          (let ((egg (car args)))
            (alist-ref (if (string? egg)
                           (string->symbol egg)
                           egg)
                       info))))))

(define egg-dependencies
  (let ((eggs/deps '()))
    (lambda args
      (when (null? eggs/deps)
        (set! eggs/deps
              (map (lambda (egg-data)
                     (let* ((egg (car egg-data))
                            (data (cdr egg-data))
                            (needs (or (alist-ref 'needs data) '()))
                            (depends (or (alist-ref 'depends data) '())))
                       (cons egg
                             (append needs
                                     (let loop ((deps depends))
                                       (if (null? deps)
                                           '()
                                           (let ((dep (car deps)))
                                             (cons
                                              (if (pair? dep)
                                                  (car dep)
                                                  dep)
                                              (loop (cdr deps))))))))))
                   (egg-info))))
      (if (null? args)
          eggs/deps
          (let ((egg (car args)))
            (alist-ref (if (string? egg)
                           (string->symbol egg)
                           egg)
                       eggs/deps))))))

(define (safe-car x) (and x (car x)))

(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))
                                 ((_    egg-info-str) (egg-extension-information egg)))
                        (let* ((egg-install-info   (read (open-input-string egg-info-str)))
                               (egg-install-ver    (safe-car (alist-ref 'version egg-install-info)))
                               (egg-info           (alist-ref (string->symbol egg) ((egg-information))))
                               (egg-ver            (safe-car (alist-ref 'version egg-info))))
                          (let ((egg-version-check (or (not egg-install-ver)
                                                       (not egg-ver) (and (string? egg-ver) (string-null? egg-ver))
                                                       (string=? (->string egg-install-ver) (->string egg-ver)))))
                            (print (string-pad
                                    (cond ((and egg-version-check (zero? status))
                                           (set! successful (cons egg successful))
                                           "[ok]")
                                          (else (set! fail (cons egg fail))
                                                "[error]"))
                                    (- 50 (string-length egg))))
                            (let ((messages
                                   (string-append
                                    output "\n"
                                    (if (and (zero? status) (not egg-version-check))
                                        (sprintf "Salmonella error: mismatch between installed egg version ~a and declared egg version ~a\n"
                                                 egg-install-ver egg-ver)
                                        ""))))
                              (when (logfile) (report egg status messages
                                                      egg-install-info: egg-install-info))))))
                    (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; }
.even { background-color: #CCC; }
#egg-fail { font-weight: bold; color: red; }
#egg-ok { font-weight: bold; color: blue; }
.odd { background-color: #FFFFCC; }")

;;; A simple web-scheme replacement

(define s+ string-append)

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

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

(define p (make-tag 'p))
(define div (make-tag 'div))
(define span (make-tag 'div))
(define pre (make-tag 'pre))
(define td (make-tag 'td))
(define tr (make-tag 'tr))
(define th (make-tag 'th))
(define table (make-tag 'table))
(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 (div contents id: "content")))))

(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
          'even
          'odd))))

(define (ws:make-table alist #!optional with-header)
  (table
   (string-append
    (if with-header
        (tr (string-intersperse (map th (car alist))))
        "")
    (string-intersperse
     (map (lambda (line)
            (tr (string-intersperse (map td line) "") class: (alternate-odd/even)))
          (if with-header
              (cdr alist)
              alist))
     ""))))

(define (report->html)

  (define (link-egg-doc egg #!optional use-egg-name)
    (a (conc "http://wiki.call-cc.org/egg/" egg)
       (if use-egg-name (->string egg) "egg page")))

  (define (link-egg-deps egg)
    (if (dep-graphs-dir)
        (a (make-pathname (or (dep-graphs-webdir) (dep-graphs-dir)) (->string egg) ".png")
           "dependencies")
        ""))

  (define (egg-license egg)
    (or (and-let* ((license (alist-ref 'license (egg-info egg))))
          (car license))
        "Could not find license info"))

  (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 (let ((h '("Egg" "Version" "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)
                            (a (make-pathname (list (base-uri) (html-output)) egg ".html") "permalink")
                            (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 (cut link-egg-doc <> 'use-egg-name)
                                                   (filter (lambda (egg)
                                                             (egg-fail? egg eggs))
                                                           (egg-dependencies egg)))
                                              ", ")))
                          data))))))
           (sort eggs (lambda (s1 s2) (string< (car s1) (car s2))))))
     'with-header))

  (define (dot-installed?)
    (zero? (system:status "dot -V")))

  (define (generate-dependencies-graphs eggs)

    (define (dep-graph->dot eggname #!key (raw #f))
      (define labels "")
      (define links '())

      (define (scm->dot name)
        (let ((name (->string name)))
          (if (equal? name "digraph")
              (string-append name "_") ;; digraph egg
              (string-append
               "_" ;; for eggnames starting with numbers (e.g., 9p)
               (string-translate (->string name) "-" "_")))))

      (define (add-link! from to)
        (unless (member (cons from to) links)
          (set! links (cons (cons from to) links))))

      (define (links->string)
        (string-intersperse
         (map (lambda (link)
                (string-append (scm->dot (car link)) " -> "
                               (scm->dot (cdr link)) ";\n"))
              links)))

      (define (link-dependencies egg #!optional version)
        (let ((deps (egg-dependencies egg)))
          (with-output-to-string
            (lambda ()
              (let ((dot-egg (scm->dot egg)))
                (set! labels
                      (string-append
                       labels dot-egg
                       " [label=\"" (->string egg)
                       (if version
                           (conc " (" version ")")
                           "")
                       "\\n"
                       " (" (egg-license egg) ")\"]\n"))
                (for-each (lambda (egg-dep)
                            (let ((eggname (if (pair? egg-dep)
                                               (car egg-dep)
                                               egg-dep))
                                  (version (and (pair? egg-dep)
                                                (cadr egg-dep))))
                              (add-link! egg eggname)
                              (link-dependencies eggname version)))
                          deps))))))
      (link-dependencies eggname)
      (string-append "digraph eggs {\n" labels "\n" (links->string) "\n}"))

    (define (dep-graph->graphic eggname #!key (raw #f) (format 'png))
      (let ((dot-file (make-pathname (dep-graphs-dir) (->string eggname) "dot")))
        (with-output-to-file dot-file
          (lambda ()
            (print (dep-graph->dot eggname raw: raw))))
        (system (conc "dot -T" format " "
                      " -o " (make-pathname (dep-graphs-dir) eggname (->string format)) " "
                      dot-file " &"))))

    (for-each dep-graph->graphic (eggs))
    ) ; end generate-dependencies-graph



  (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"    ,(span (number->string fail-count) id: "egg-fail"))
                 ("Succeeded" ,(span (number->string success-count) id: "egg-ok"))
                 ("Skipped"   ,(length (skip-eggs)))
                 ("Total"     ,(span (number->string total) id: "egg-total"))))
              (h2 "Eggs")
              (h3 "Failed") (tabularize-eggs fail css 'fail)
              (h3 "Succeeded") (tabularize-eggs success css)
              (if (null? (skip-eggs))
                  ""
                  (string-append
                   (h3 "Skipped")
                   (ws:make-table (append '(("Egg")) (map list (skip-eggs))) 'with-header)))))
           (h2 "Environment")
           (pre env-report)
           (p (conc "Finished at: " (current-time))))
          css: css
          page-title: "Salmonella report"))))
    (when (dep-graphs-dir)
      (if (dot-installed?)
          (begin
            (show "Generating dependencies graphs")
            (unless (file-exists? (dep-graphs-dir))
              (create-directory (dep-graphs-dir) 'with-parents))
            (generate-dependencies-graphs (eggs)))
          (show "Not generating dependencies graphs: could not find `dot'.")))
    )) ;; end report->html

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