(module wald ()

(import scheme)
(import (chicken base))
(import (chicken format))
(import (chicken port))
(import (chicken process-context))
(import (chicken sort))
(import (chicken string))
(import (srfi 1))
(import (srfi 69))
(import doctype)
(import intarweb)
(import spiffy)
(import sxml-transforms)
(import uri-common)

;; adapted from openssl
(define-values (open-connection close-connection call-with-transaction
                                query-filters query-species)
  (let ((db (string->symbol (or (get-environment-variable "DB") "json"))))
    (case db
      ((json)
       (import (wald json))
       (values open-connection close-connection call-with-transaction
               query-filters query-species))
      ((sqlite)
       (import (wald sqlite))
       (values open-connection close-connection call-with-transaction
               query-filters query-species))
      ((nstore)
       (import (wald nstore))
       (values open-connection close-connection call-with-transaction
               query-filters query-species))
      (else
       (error "Unknown DB" db)))))

(define connection-options '((read-only? . #t)))
(define connection (make-parameter #f))
(define filters (make-parameter '()))

(define (group-by key-proc value-proc items)
  (define (make-cons value)
    (lambda (values)
      (cons value values)))
  (let ((ht (make-hash-table)))
    (for-each (lambda (item)
                (let ((key (key-proc item))
                      (value (value-proc item)))
                  (hash-table-update!/default ht key (make-cons value) '())))
              items)
    (hash-table->alist ht)))

(define (group-filters filters)
  (sort
   (map (lambda (item)
          (let ((key (car item))
                (value (cdr item)))
            (cons key (sort value string<?))))
        (group-by car cadr filters))
   (lambda (a b)
     (string<? (car a) (car b)))))

(define (group-params params)
  (map (lambda (group)
         (let ((key (car group))
               (values (cdr group)))
           (cons (symbol->string key) values)))
       (group-by car cdr params)))

(define (filter-valid? filter)
  (let* ((key (symbol->string (car filter)))
         (value (cdr filter))
         (values (alist-ref key (filters) equal?)))
    (and values (member value values))))

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

(define (page-html #!key species (params '()) error)
  (define (wikipedia-link title)
    (format "https://en.wikipedia.org/wiki/~a" title))
  (sxml->html
   `(html
     (@ (lang "en"))
     (head
      (meta (@ (charset "utf-8")))
      (meta (@ (name "viewport")
               (content ,(string-append "initial-scale=1.0,"
                                        "width=device-width,"
                                        "user-scalable=no"))))
      (link (@ (href "style.css") (rel "stylesheet") (type "text/css")))
      (title "Wikipedia-powered mushroom identification"))
     (body
      (h1 "Mushroom identification")
      (form
       (@ (action "/") (method "post"))
       ,@(let ((selected (group-params params)))
           (map (lambda (filter)
                  (let* ((name (car filter))
                         (selected-values (or (alist-ref name selected equal?)
                                              '())))
                    `(select
                       (@ (multiple) (size "10") (name ,name))
                       (optgroup
                        (@ (label ,name))
                        (option (@ (value "")
                                   ,@(if (or (null? selected-values)
                                             (equal? selected-values '("")))
                                         '(selected)
                                         '()))
                                "Select")
                        ,@(map (lambda (value)
                                 `(option (@ (value ,value)
                                             ,@(if (member value selected-values)
                                                   '(selected)
                                                   '()))
                                          ,value))
                               (cdr filter))))))
                (filters)))
       (p
        (button (@ (name "submit") (type "submit")) "Query")
        (button (@ (name "submit") (type "button")
                   (onclick "document.querySelectorAll('option').forEach(function(o){o.selected=o.value===\"\"})"))
                "Reset")))
      ,@(cond
         (species
          `((p
             ,(let ((results (length species)))
                (format "~a result~a~a"
                        results
                        (if (= results 1) "" "s")
                        (if (zero? results) "" ":")))
             (ul
              ,@(map (lambda (title)
                       `(li (a (@ (href ,(wikipedia-link title))) ,title)))
                     (sort species string<?))))))
         (error
          `((p (@ (class "error")),error)))
         (else
          '()))))))

(define (handle-request continue)
  (let* ((request (current-request))
         (method (request-method request))
         (path (uri-path (request-uri request))))
    (cond
     ((and (eq? method 'GET) (equal? path '(/ "")))
      (send-response body: (page-html)))
     ((and (eq? method 'POST) (equal? path '(/ ""))
           ((request-has-message-body?) request))
      (let* ((params (read-urlencoded-request-data request))
             (query (map (lambda (param)
                           (list (symbol->string (car param))
                                 (cdr param)))
                         (filter filter-valid? params))))
        (if (null? query)
            (send-response body: (page-html error: "Empty query"))
            (let ((species (call-with-transaction (connection)
                                                  (lambda (tx)
                                                    (query-species tx query)))))
              (send-response body: (page-html species: species
                                              params: params))))))
     (else
      (continue)))))

(define (main db-path #!optional (host "127.0.0.1") (port "8080"))
  (connection (open-connection db-path connection-options))
  (filters (group-filters (call-with-transaction (connection) query-filters)))
  (trusted-proxies (list host))
  (vhost-map `((".*" . ,handle-request)))
  (root-path "static/")
  (server-bind-address host)
  (server-port (string->number port))
  (set-buffering-mode! (current-output-port) #:line)
  (access-log (current-output-port))
  (start-server))

(apply main (command-line-arguments))

)