Update server.

5 files changed, 78 insertions, 64 deletions

diff --git a/module/config.scm b/module/config.scm
index a14883ec..08c678c9 100644
--- a/module/config.scm
+++ b/module/config.scm
@@ -10,7 +10,7 @@
              (ice-9 rdelim)
              (glob))
 
-(calendar-files (glob "~/.calendars/*"))
+(calendar-files (glob "~/.local/var/cal/*"))
 
 ;;; TODO possibly replace with propper lookup
 (define my-courses
diff --git a/module/server.scm b/module/server.scm
index 812f2453..1e7e1c47 100644
--- a/module/server.scm
+++ b/module/server.scm
@@ -1,79 +1,88 @@
 (define-module (server)
-  #:use-module (util))
+  :use-module (util))
 
 (use-modules* (web (server request response uri))
               (output (html))
               (server (util macro))
-              (ice-9 (match control rdelim curried-definitions
-                            regex #| regex here due to bad macros |#  ))
+              (sxml (simple))
+              (ice-9 (match control rdelim curried-definitions ftw
+                            getopt-long
+                            iconv regex #| regex here due to bad macros |#  ))
               (srfi (srfi-1 srfi-19 srfi-88)))
 
-(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* (date key: (year 0) (month 0) (day 0) (hour 0) (minute 0) (second 0) (nsecs 0) (zone 0))
-  (make-date nsecs second minute hour day month year zone))
+(use-modules (srfi srfi-19 util))
+
+(define (file-extension name)
+  (car (last-pair (string-split name #\.))))
+
+(define (sxml->xml-string sxml)
+  (with-output-to-string
+    (lambda () (sxml->xml sxml))))
+
+(define (directory-table dir)
+  `(table
+    (thead
+     (tr (th "Name") (th "Type") (th "Perm")))
+    (tbody
+     ,@(map (lambda (kv)
+              (let* (((k stat) kv))
+                `(tr (td (a (@ (href ,dir ,k)) ,k))
+                     (td ,(stat:type stat))
+                     (td ,(number->string (stat:perms stat) 8)))))
+            (cddr (file-system-tree dir))))))
+
 
 (define (make-make-routes calendar events)
   (make-routes
 
-   (GET "/" (m)
-        (let* ((start (if m
+   (GET "/" (y m) ; m in [1, 12]
+        (let* ((cd (current-date))
+               (start (if m
                           (date year: 2019 day: 1 month: (string->number m))
                           (current-date)))
                (end (set (date-month start) = (+ 1))))
+
           (return '((content-type text/html))
                   (with-output-to-string
                     (lambda () (html-generate calendar events start end))))))
 
-   (GET "/static/:filename/" (filename)
-        ((serve-file return) filename))
+   (GET "/static" ()
+        (return
+         '((content-type text/html))
+         (sxml->xml-string
+          (directory-table "static/"))))
+
+   (GET "/static/:filename" (filename)
+        (return
+         `((content-type ,(case (string->symbol (file-extension filename))
+                            ((js) 'text/javascript)
+                            ((css) 'text/css))))
+         (call-with-input-file (string-append "static/" filename) read-string)))
+
+   (GET "/count" ()
+        ;; (sleep 1)
+        (return '((content-type text/plain))
+                (string-append (number->string state) "\n")
+                (1+ state)))
 
    ))
 
+(define options
+  '((port (value #t) (single-char #\p))
+    (addr (value #t))))
 
 (define-public (server-main c e args)
-  (run-server (make-make-routes c e)))
+
+  (define opts (getopt-long args options))
+  (define port (option-ref opts 'port 8080))
+  (define addr (inet-aton (option-ref opts 'addr "127.0.0.1")))
+
+  (format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%"
+          (inet-ntoa addr) port
+          (getpid) (getcwd))
+
+  (run-server (make-make-routes c e)
+              'http
+              `(port: ,port
+                addr: ,addr)
+              0))
diff --git a/module/server/macro.scm b/module/server/macro.scm
index f920a663..71452d0f 100644
--- a/module/server/macro.scm
+++ b/module/server/macro.scm
@@ -52,7 +52,7 @@
 
 (define-macro (make-routes . routes)
 
-  `(lambda (request body . state)
+  `(lambda* (request body #:optional state)
      (let ((r:method  (request-method  request))
            (r:uri     (request-uri     request))
            (r:version (request-version request))
@@ -81,5 +81,5 @@
                            (when (memv 'application/x-www-form-urlencoded
                                     (or (assoc-ref r:headers 'content-type) '()))
                              (parse-query (uri-decode (bytevector->string body "UTF-8")))))))))
-           (lambda (a b . new-state)
-             (values a b (if (null? new-state) state (car new-state)))))))))
+           (lambda* (a b #:optional new-state)
+             (values a b (or new-state state))))))))
diff --git a/module/server/test.scm b/module/server/test.scm
index f28b1152..d33be67f 100644
--- a/module/server/test.scm
+++ b/module/server/test.scm
@@ -15,7 +15,9 @@
              (srfi srfi-88)
 
              (sxml simple)
-             (ice-9 ftw))
+             (ice-9 ftw)
+             (ice-9 rdelim)
+             )
 
 (define (form-page name)
   `(div
@@ -68,8 +70,7 @@
 
    (GET "/ls/:file" (file)
         (return '((content-type text/plain))
-                (call-with-input-file (string-append "./" file)
-                  (@ (ice-9 rdelim) read-string))))))
+                (call-with-input-file file read-string)))))
 
 (run-server routes 'http '() "Default Name")
 
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
index 29f5450f..2e969f6e 100644
--- a/module/srfi/srfi-19/util.scm
+++ b/module/srfi/srfi-19/util.scm
@@ -11,7 +11,8 @@
             ;; time-add
             make-duration
             time->string
-            add-day remove-day))
+            add-day remove-day
+            date))
 
 #;
 (define (copy-date date)
@@ -129,3 +130,6 @@ attribute set to 0. Can also be seen as \"Start of day\""
 ;; TODO actually allow many form date form.
 (define-public (parse-freeform-date str)
   (string->date str "~Y-~m-~d"))
+
+(define* (date #:key (year 0) (month 0) (day 0) (hour 0) (minute 0) (second 0) (nsecs 0) (zone 0))
+  (make-date nsecs second minute hour day month year zone))