diff options
| -rwxr-xr-x | module/main.scm | 4 | ||||
| -rw-r--r-- | module/output/html.scm | 19 | ||||
| -rw-r--r-- | module/server.scm | 55 |
3 files changed, 70 insertions, 8 deletions
diff --git a/module/main.scm b/module/main.scm index 24fdf193..8b36d305 100755 --- a/module/main.scm +++ b/module/main.scm @@ -17,6 +17,7 @@ (output html) (output terminal) (output none) + (server) (ice-9 getopt-long) @@ -72,7 +73,8 @@ ((case (string->symbol (car ropt)) ((none) none-main) ((html) html-main) - ((term) terminal-main)) + ((term) terminal-main) + ((server) server-main)) c e ropt))) #:calendar-files (or (and=> (option-ref opts 'files #f) list) diff --git a/module/output/html.scm b/module/output/html.scm index 0c8c3eb3..0e6f0813 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -211,17 +211,12 @@ (cons `(tr ,@w) (recur rest))))))))) -(define-public (html-main calendars events args) - - (define opts (getopt-long args opt-spec)) - - (define start (parse-freeform-date (option-ref opts 'from "2019-04-15"))) - (define end (parse-freeform-date (option-ref opts 'to "2019-05-10"))) - +(define-public (html-generate calendars events start end) (define evs (get-groups-between (group-stream events) start end)) ;; (display "<!doctype HTML>") (newline) + ((@ (sxml simple) sxml->xml) `(html (@ (lang sv)) (head @@ -255,3 +250,13 @@ (current-date)))) (div (@ (class "eventlist")) ,@(stream->list (stream-map fmt-day evs))))))))) + +(define-public (html-main calendars events args) + (define opts (getopt-long args opt-spec)) + (define start (parse-freeform-date (option-ref opts 'from "2019-04-15"))) + (define end (parse-freeform-date (option-ref opts 'to "2019-05-10"))) + + + (html-generate calendars events start end)) + + diff --git a/module/server.scm b/module/server.scm new file mode 100644 index 00000000..063f6fc7 --- /dev/null +++ b/module/server.scm @@ -0,0 +1,55 @@ +(define-module (server) + #:use-module (util)) + +(use-modules* (web (server request response uri)) + (output (html)) + (ice-9 (match control rdelim curried-definitions)) + (srfi (srfi-1 srfi-19))) + +(define month-names + '(jan feb mar apr may jun jul aug sep oct nov dec)) + +(define month-numbers + (map cons month-names (iota 12 1))) + +(define (query->alist str) + (map (lambda (s) (let* (((k . v) (string-split s #\=))) + (cons (string->symbol (string-downcase k)) v))) + (filter (negate string-null?) (string-split str #\&)))) + + +(define ((serve-file continuation) path-list) + (continuation + '((content-type text/css)) + ;; TODO document root somewhere around here + (call-with-input-file (string-append "./" (string-join path-list "/")) + read-string))) + +;;; TODO "/static/*" +(define (make-handler calendars events) + (lambda (request request-body) + (format (current-error-port) "[~a] ~a~%" + (date->string (current-date) "~3") + request) + (call/ec + (lambda (ret) + (let* ((uri (request-uri request))) + (match uri + (($ (@@ (web uri) <uri>) scheme userinfo host port path query fragment) + (let* ((path-parts (string-split path #\/))) + ;; This is actually quite ugly + (and=> (member "static" path-parts) (serve-file ret)) + + (let* ((query (query->alist (or query ""))) + (m (and=> (assoc-ref query 'm) + (compose (lambda (k) (assoc-ref month-numbers k)) string->symbol car)))) + (when m + (let* ((start (make-date 0 0 0 0 1 m 2019 0)) + (end (make-date 0 0 0 0 1 (1+ m) 2019 0)) + (str (with-output-to-string (lambda () (html-generate calendars events start end))))) + (ret `((content-type text/html)) str))) + (ret (build-response #:code 404) + "404 Not Fonud")))))))))) + +(define-public (server-main c e args) + (run-server (make-handler c e))) |