(module web-app ()

(import scheme)
(import (chicken base))
(import (chicken format))
(import (chicken port))
(import (chicken process-context))
(import (chicken time posix))
(import (srfi 1))
(import doctype)
(import intarweb)
(import spiffy)
(import sxml-transforms)
(import uri-common)
(import utf8)

(define stderr (current-error-port))

(define host "127.0.0.1")

(include "food.scm")

(define (generate-response month)
  (with-output-to-string
    (lambda ()
      (SRV:send-reply
       (pre-post-order*
        `((doctype-html)
          (html
           (@ (lang "de"))
           (head
            (meta (@ (charset "utf-8")))
            (meta (@ (name "viewport")
                     (content ,(string-append "initial-scale=1.0,"
                                              "width=device-width,"
                                              "user-scalable=no"))))
            (meta (@ (name "apple-mobile-web-app-capable")
                     (content "yes")))
            (title "Welches Obst und Gemüse kann regional gekauft werden?")
            (link (@ (href "touch-icon-iphone.png")
                     (rel "apple-touch-icon")))
            (link (@ (href "favicon.ico")
                     (rel "icon")
                     (type "image/x-icon")))
            (link (@ (href "style.css")
                     (rel "stylesheet")
                     (type "text/css")))
            (script (@ (src "index.js")
                       (type "text/javascript"))
                    ""))
           (body
            (table
             (@ (class "legend"))
             (caption "Farbtabelle")
             (tbody
              (tr
               (td (@ (class "availability none")))
               (td "nicht vorhanden"))
              (tr
               (td (@ (class "availability storage")))
               (td "aus Lagerung"))
              (tr
               (td (@ (class "availability fresh")))
               (td "frisch"))))
            (table
             (@ (class "food"))
             ,@(map
                (lambda (section)
                  (let ((type (car section))
                        (items (cdr section)))
                    `((thead
                       (tr
                        (th ,type)
                        ,@(map
                           (lambda (i)
                             `(th (@ (class ,(string-append "availability"
                                                            (if (= i month)
                                                                " current-month"
                                                                ""))))
                                  ,(substring (vector-ref months i) 0 1)))
                           (iota 12))))
                      (tbody
                       ,@(map
                          (lambda (item)
                            (let* ((name (car item))
                                   (yearly-availability (cdr item))
                                   (yearly-availability (string-translate yearly-availability " "))
                                   (availability (string-ref yearly-availability month))
                                   (hidden? (eqv? availability #\_))
                                   (class (if hidden? "hidden" "")))
                              `(tr (@ (class ,class))
                                   (td ,name)
                                   ,@(map
                                      (lambda (i)
                                        (let* ((availability (string-ref yearly-availability i))
                                               (availability-class (case availability
                                                                     ((#\_) "none")
                                                                     ((#\o) "storage")
                                                                     ((#\O) "fresh")))
                                               (class (format "availability ~a" availability-class))
                                               (class (if (= i month)
                                                          (string-append class " current-month")
                                                          class)))
                                          `(td (@ (class ,class)))))
                                      (iota 12)))))
                          items)))))
                food)))))
        (append doctype-rules universal-conversion-rules*))))))

(define generated-responses (list->vector (map generate-response (iota 12))))

(define time/month 4)

(define (handle-request continue)
  (let* ((request (current-request))
         (method (request-method request))
         (path (uri-path (request-uri request))))
    (if (and (eq? method 'GET) (equal? path '(/ "")))
        (let* ((month (vector-ref (seconds->utc-time) time/month))
               (response (vector-ref generated-responses month)))
          (send-response body: response))
        (continue))))

(define (spiffy-loop port)
  (trusted-proxies (list host))
  (vhost-map `((".*" . ,handle-request)))
  (root-path "static/")
  (server-bind-address host)
  (server-port port)
  (set-buffering-mode! (current-output-port) #:line)
  (access-log (current-output-port))
  (print "starting server on http://" host ":" port)
  (start-server))

(define main
  (case-lambda
   ((port)
    (spiffy-loop (string->number port)))
   (_
    (fprintf stderr "usage: ~a <port>\n" (program-name))
    (exit 1))))

(apply main (command-line-arguments))

)