(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken file))
(import (chicken format))
(import (chicken io))
(import (chicken pathname))
(import (chicken port))
(import (chicken process-context))
(import (chicken sort))
(import (chicken string))
(import (chicken time posix))
(import (srfi 1))
(import (srfi 69))
(import doctype)
(import http-client)
(import salmonella)
(import salmonella-log-parser)
(import scsh-process)
(import sxml-transforms)

(define stderr (current-error-port))
(define debug? (get-environment-variable "DEBUG"))

(define (group-report-logs-by-egg report-logs)
  (define (hash-table-push! hash-table key value)
    (define (updater items) (cons value items))
    (hash-table-update!/default hash-table key updater '()))
  (let ((egg-records (make-hash-table)))
    (for-each
     (lambda (report-log)
       (and-let* ((egg-name (report-egg report-log)))
         (hash-table-push! egg-records egg-name report-log)))
     report-logs)
    egg-records))

(define (process-report job url)
  (let ((compressed-report-path (create-temporary-file ".log.bz2"))
        (report-path (create-temporary-file ".log")))
    (if debug?
        (copy-file (make-pathname (list "reports" job) "salmonella.log.bz2")
                   compressed-report-path
                   'clobber)
        (call-with-output-file compressed-report-path
          (lambda (out)
            (call-with-input-request url #f (lambda (in) (copy-port in out))))))
    (run (bzip2 -dc ,compressed-report-path) (> ,report-path))
    (let ((report-logs (read-log-file report-path)))
      (delete-file* compressed-report-path)
      (delete-file* report-path)
      (group-report-logs-by-egg report-logs))))

(define (sxml->html sxml)
  (SRV:send-reply
   (pre-post-order
    `((doctype-html) ,sxml)
    (append doctype-rules universal-conversion-rules))))

(define (make-comparator compare key)
  (lambda (a b)
    (compare (key a) (key b))))

(define (generate-dashboard-html dashboard datetime)
  (let ((egg-names (sort (hash-table-keys dashboard)
                         (make-comparator string<? ->string))))
    (sxml->html
     `(html
       (@ (lang "en"))
       (head
        (meta (@ (charset "utf-8")))
        (meta (@ (name "viewport") (content "width=device-width")))
        (link (@ (href "style.css") (rel "stylesheet") (type "text/css")))
        (title "Salmonella Dashboard"))
       (body
        (h1 "Salmonella Dashboard")
        (table
         (@ (class "eggs"))
         (thead
          (tr
           (th "Status")
           (th "Name")
           (th "Details")))
         (tbody
          ,@(map
             (lambda (egg-name)
               (let* ((jobs (hash-table-ref dashboard egg-name))
                      (status (hash-table-fold jobs
                                               (lambda (job meta seed)
                                                 (cond
                                                  ((hash-table-ref meta 'status)
                                                   (cons (cons job meta) seed))
                                                  (else
                                                   seed)))
                                               '()))
                      (color (if (null? status) "green" "red")))
                 `(tr
                   (@ (class ,color))
                   (td (@ (class "egg-status"))
                       ,(if (equal? color "green") "✓" "✗"))
                   (td (@ (class "egg-name")) ,egg-name)
                   (td
                    (@ (class "egg-detail"))
                    ,@(if (equal? color "red")
                          (intersperse
                           (map
                            (lambda (job-status)
                              (let* ((job (car job-status))
                                     (meta (cdr job-status))
                                     (status (hash-table-ref meta 'status))
                                     (detail-url (hash-table-ref meta 'detail-url)))
                                `(a (@ (href ,detail-url))
                                    (string-append ,job ": " ,status))))
                            (sort status (make-comparator string<? car)))
                           '(br))
                          '())))))
             egg-names)))
        (div
         (@ (class "dashboard-info"))
         ,(let ((timestamp (time->string datetime "%Y-%m-%d %H:%M:%S%z")))
            (string-append "Generated on " timestamp))))))))

(define (egg-status egg-logs)
  (any
   (lambda (egg-log)
     (let ((action (report-action egg-log))
           (status (report-status egg-log)))
       (if (and (number? status) (> status 0)
                (memv action '(fetch install test)))
           action
           #f)))
   egg-logs))

(define (process-reports config)
  (let* ((dashboard (make-hash-table))
         (reports (alist-ref 'reports config))
         (datetime (seconds->local-time))
         (year (time->string datetime "%Y"))
         (month (time->string datetime "%m"))
         (day (time->string datetime "%d")))
    (when (not reports)
      (error "Feeds not found in config"))
    (for-each
     (lambda (report)
       (let* ((job (alist-ref 'job report))
              (url (alist-ref 'report-url report))
              (detail-url (alist-ref 'detail-url report)))
         (when (not job)
           (error "Job not found in report" report))
         (when (not url)
           (error "URL not found in report" report))
         (when (not detail-url)
           (error "Detail URL not found in report" report))
         (let* ((url (string-translate* url `(("{year}" . ,year)
                                              ("{month}" . ,month)
                                              ("{day}" . ,day))))
                (grouped-reports (condition-case
                                  (process-report job url)
                                  ((exn http client-error) (make-hash-table)))))
           (hash-table-walk
            grouped-reports
            (lambda (egg logs)
              (when (not (hash-table-ref/default dashboard egg #f))
                (hash-table-set! dashboard egg (make-hash-table)))
              (let ((job-table (hash-table-ref dashboard egg)))
                (hash-table-set! job-table job (make-hash-table))
                (let ((job-info (hash-table-ref job-table job))
                      (status (egg-status logs)))
                  (hash-table-set! job-info 'status status)
                  (when status
                    (let* ((action (if (eqv? status 'fetch)
                                       "install"
                                       (symbol->string status)))
                           (egg (->string egg))
                           (url (string-translate* detail-url
                                                   `(("{year}" . ,year)
                                                     ("{month}" . ,month)
                                                     ("{day}" . ,day)
                                                     ("{action}" . ,action)
                                                     ("{egg}" . ,egg)))))
                      (hash-table-set! job-info 'detail-url url))))))))))
     reports)
    (generate-dashboard-html dashboard datetime)))

(define (generate-dashboard config-path out-path)
  (let ((config (call-with-input-file config-path read-list)))
    (if out-path
        (with-output-to-file out-path
          (lambda ()
            (process-reports config)))
        (process-reports config))))

(define main
  (case-lambda
   ((config-path)
    (generate-dashboard config-path #f))
   ((config-path out-path)
    (generate-dashboard config-path out-path))
   (_
    (fprintf stderr "usage: ~a <config-path> [out-path]\n" (program-name))
    (exit 1))))

(apply main (command-line-arguments))