Rewrote make-routes to use define-syntax.

This is the first step into adding extra functionallity, since I now
want have to worry about how namespace pollution works.

4 files changed, 123 insertions, 87 deletions

diff --git a/module/calp/repl.scm b/module/calp/repl.scm
index 7beee560..aaa1061c 100644
--- a/module/calp/repl.scm
+++ b/module/calp/repl.scm
@@ -5,6 +5,7 @@
 (define-module (calp repl)
   :use-module (system repl server)
   :use-module (ice-9 regex)
+  :use-module (ice-9 format)
   :use-module ((calp util hooks) :select (shutdown-hook))
   :use-module ((hnh util exceptions) :select (warning))
   :use-module (calp translation)
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index ed2c1b2d..6701d8b4 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -163,8 +163,7 @@
                                       next-start: (lambda (d) (date+ d (date day: 7)))
                                       prev-start: (lambda (d) (date- d (date day: 7)))
                                       render-calendar: (@ (calp html view calendar week) render-calendar)
-                                      intervaltype: 'week
-                                      )))))))
+                                      intervaltype: 'week)))))))
 
    (GET "/month/:start-date.html" (start-date html)
         (let ((start-date (start-of-month (parse-iso-date start-date))))
diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm
index aa3be1ed..c3d8b997 100644
--- a/module/web/http/make-routes.scm
+++ b/module/web/http/make-routes.scm
@@ -3,15 +3,28 @@
   :use-module (ice-9 regex)
   :use-module (ice-9 match)
   :use-module (ice-9 curried-definitions)
+  :use-module (ice-9 control)
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
+  :use-module ((web query) :select (parse-query))
+  :use-module ((web response) :select (build-response))
+  :use-module ((ice-9 iconv) :select (bytevector->string))
   :export (parse-endpoint-string
            make-routes)
   )
 
 
 
+;; Parses an endpoint description, and returns two values:
+;; - a regex string which matches the rule
+;; - the list of symbols embedded int the string
+;; An endpoint string looks like
+;; /calendar/:uid{.*}.ics
+;; Where "/calendar/" matches literally
+;; followed by something matching ".*"
+;; followed by something literally matching ".ics"
+;; and '(uid) would be the second return
 (define (parse-endpoint-string str)
   (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?")))
     (let loop ((str str)
@@ -38,87 +51,113 @@
                   (cons (string->symbol (match:substring m 1))
                         tokens)))))))
 
-
-(define ((generate-case regex-table) defn)
-  (match defn
+(define ((generate-case regexes r:method r:path) stx)
+  (syntax-case stx ()
     ((method uri param-list body ...)
-     (let* ((_ tokens (parse-endpoint-string uri))
-               (diff intersect (lset-diff+intersection eq? param-list tokens)))
-          `((and (eq? r:method (quote ,method))
-                 (regexp-exec ,(car (assoc-ref regex-table uri)) r:path))
-            => (lambda (match-object)
-                 ;; (assert
-                 ;;  (= (1- (match:count match-object))
-                 ;;     (length intersect)))
+     (let* ((regex tokens (parse-endpoint-string (syntax->datum #'uri)))
+            (diff intersect (lset-diff+intersection eq? (syntax->datum #'param-list)
+                                                    tokens))
+            (argument-list (if (null? diff)
+                               #'() #`(key: #,@(map (lambda (x) (datum->syntax stx x)) diff)
+                                            allow-other-keys: rest: rest)))
+            (intersect-list (map (lambda (x) (datum->syntax stx x)) intersect))
+            (rx-var (list-ref (assoc regex regexes) 1)))
+       #`((and (eq? #,r:method (quote method))
+               (regexp-exec #,rx-var #,r:path))
+          => (lambda (match-object)
+               ;; Those parameters which were present in the template uri
+               ((lambda #,intersect-list
+                  ;; Those that only are in the query string
+                  (lambda* #,argument-list body ...))
+                #,@(unless (null? intersect)
+                     (map (lambda (i) #`(match:substring match-object #,i))
+                          (cdr (iota (1+ (length intersect)))))))))))))
+
+
+(define-syntax (make-routes stx)
+  (syntax-case stx ()
+    ((_ routes ...)
+     (with-syntax ((r:method   (datum->syntax stx 'r:method))
+                   (r:uri      (datum->syntax stx 'r:uri))
+                   (r:version  (datum->syntax stx 'r:version))
+                   (r:headers  (datum->syntax stx 'r:headers))
+                   (r:meta     (datum->syntax stx 'r:meta))
+                   (r:scheme   (datum->syntax stx 'r:scheme))
+                   (r:userinfo (datum->syntax stx 'r:userinfo))
+                   (r:host     (datum->syntax stx 'r:host))
+                   (r:port     (datum->syntax stx 'r:port))
+                   (r:path     (datum->syntax stx 'r:path))
+                   (r:query    (datum->syntax stx 'r:query))
+                   (r:fragment (datum->syntax stx 'r:fragment))
+
+                   (return  (datum->syntax stx 'return))
+                   (request (datum->syntax stx 'request))
+                   (body    (datum->syntax stx 'body))
+                   (state   (datum->syntax stx 'state))
+                   )
+
+       ;; Ensures that all regexes are only compiled once.
+       ;; Given (GET "/today/" (view date) body ...)
+       ;; returns ("/today/" #'*random-symbol* #'(make-regexp "^/today//?$" regexp/icase))
+       (define routes-regexes
+         (map (lambda (stx-1)
+                (syntax-case stx-1 ()
+                  ((%fst uri %rest ...)
+                   (let ((regex _ (parse-endpoint-string (syntax->datum #'uri))))
+                     (list regex (datum->syntax stx (gensym "rx-"))
+                           #`(make-regexp #,(string-append "^" regex "/?$") regexp/icase))))))
+              #'(routes ...)))
+
+       #`(let #,(map cdr routes-regexes)
+           (lambda* (request body optional: state)
+             ;; (format (current-error-port) "~a~%"  request)
+             ;; All these bindings generate compile time warnings since the expansion
+             ;; of the macro might not use them. This isn't really a problem.
+             (let ((r:method  ((@ (web request) request-method)  request))
+                   (r:uri     ((@ (web request) request-uri)     request))
+                   (r:version ((@ (web request) request-version) request))
+                   (r:headers ((@ (web request) request-headers) request))
+                   (r:meta    ((@ (web request) request-meta)    request)))
+               (let ((r:scheme   ((@ (web uri) uri-scheme)   r:uri))
+                     (r:userinfo ((@ (web uri) uri-userinfo) r:uri))
+                     ;; uri-{host,port} is (probably) not set when we are a server,
+                     ;; fetch them from the request instead
+                     (r:host     (or ((@ (web uri) uri-host)     r:uri)
+                                     (and=> ((@ (web request) request-host) request) car)))
+                     (r:port     (or ((@ (web uri) uri-port)     r:uri)
+                                     (and=> ((@ (web request) request-host) request) cdr)))
+                     (r:path     ((@ (web uri) uri-path)     r:uri))
+                     (r:query    ((@ (web uri) uri-query)    r:uri))
+                     (r:fragment ((@ (web uri) uri-fragment) r:uri)))
+
+                 ;; TODO propper logging
+                 (display (format #f "[~a] ~a ~a:~a~a?~a~%"
+                                  (datetime->string (current-datetime))
+                                  r:method r:host r:port r:path (or r:query ""))
+                          (current-error-port))
 
-                 ;; Those parameters which were present in the template uri
-                 ((lambda ,intersect
-                    ;; Those that only are in the query string
-                    (lambda* (,@(unless (null? diff) `(key: ,@diff allow-other-keys:))
-                              rest: rest)
-                      ,@body))
-                  ,@(unless (null? intersect)
-                      (map (lambda (i)
-                             `((@ (ice-9 regex) match:substring) match-object ,i))
-                           (cdr (iota (1+ (length intersect)))))))))))))
+                 (call-with-values
+                     (lambda ()
+                       (call/ec
+                        (lambda (return)
+                          (apply
+                           (cond #,@(map (generate-case routes-regexes #'r:method #'r:path) #'(routes ...))
+                                 (else (lambda* _ (return (build-response code: 404)
+                                                          "404 Not Fonud"))))
+                           (append
+                            (parse-query r:query)
 
-(define-macro (make-routes . routes)
-  ;; Ensures that all regexes are only compiled once.
-  (define routes-regexes
-   (map (lambda (uri)
-          (define-values (regex _) (parse-endpoint-string uri))
-          (list uri (gensym) `(make-regexp ,(string-append "^" regex "/?$") regexp/icase)))
-        (map cadr routes)))
+                            ;; When content-type is application/x-www-form-urlencoded,
+                            ;; decode them, and add it to the argument list
+                            (let ((content-type (assoc-ref r:headers 'content-type)))
+                              (when content-type
+                                (let ((type args (car+cdr content-type)))
+                                  (when (eq? type 'application/x-www-form-urlencoded)
+                                    (let ((encoding (or (assoc-ref args 'encoding) "UTF-8")))
+                                      (parse-query (bytevector->string body encoding)
+                                                   encoding)))))))))))
 
-  `(let ,(map cdr routes-regexes)
-       (lambda* (request body optional: state)
-         ;; (format (current-error-port) "~a~%"  request)
-         ;; All these bindings generate compile time warnings since the expansion
-         ;; of the macro might not use them. This isn't really a problem.
-         (let ((r:method  ((@ (web request) request-method)  request))
-               (r:uri     ((@ (web request) request-uri)     request))
-               (r:version ((@ (web request) request-version) request))
-               (r:headers ((@ (web request) request-headers) request))
-               (r:meta    ((@ (web request) request-meta)    request)))
-           (let ((r:scheme   ((@ (web uri) uri-scheme)   r:uri))
-                 (r:userinfo ((@ (web uri) uri-userinfo) r:uri))
-                 ;; uri-{host,port} is (probably) not set when we are a server,
-                 ;; fetch them from the request instead
-                 (r:host     (or ((@ (web uri) uri-host)     r:uri)
-                                 (and=> ((@ (web request) request-host) request) car)))
-                 (r:port     (or ((@ (web uri) uri-port)     r:uri)
-                                 (and=> ((@ (web request) request-host) request) cdr)))
-                 (r:path     ((@ (web uri) uri-path)     r:uri))
-                 (r:query    ((@ (web uri) uri-query)    r:uri))
-                 (r:fragment ((@ (web uri) uri-fragment) r:uri)))
-             ;; TODO propper logging
-             (display (format #f "[~a] ~a ~a:~a~a?~a~%"
-                              (datetime->string (current-datetime))
-                              r:method r:host r:port r:path (or r:query ""))
-                      (current-error-port))
-             (call-with-values
-                 (lambda ()
-                   ((@ (ice-9 control) call/ec)
-                    (lambda (return)
-                      (apply
-                       (cond ,@(map (generate-case routes-regexes) routes)
-                             (else (lambda* _ (return ((@ (web response) build-response) code: 404)
-                                                      "404 Not Fonud"))))
-                       (append
-                        ((@ (web query) parse-query) r:query)
+                   (case-lambda ((headers body new-state) (values headers body new-state))
+                                ((headers body)           (values headers body state))
+                                ((headers)                (values headers "" state))))))))))))
 
-                        ;; TODO what's happening here?
-                        (let ((content-type (assoc-ref r:headers 'content-type)))
-                          ((@ (hnh util) when) content-type
-                           (let ((type (car content-type))
-                                 (args (cdr content-type)))
-                             ((@ (hnh util) when)
-                              (eq? type 'application/x-www-form-urlencoded)
-                              (let ((encoding (or (assoc-ref args 'encoding) "UTF-8")))
-                                ((@ (web query) parse-query)
-                                 ((@ (ice-9 iconv) bytevector->string)
-                                  body encoding)
-                                 encoding)))))))))))
-               (case-lambda ((headers body new-state) (values headers body new-state))
-                            ((headers body) (values headers body state))
-                            ((headers) (values headers "" state)))))))))
diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm
index 673a4b49..4e5aa07d 100644
--- a/tests/test/annoying-events.scm
+++ b/tests/test/annoying-events.scm
@@ -17,12 +17,9 @@
 ;; TODO remove this
 (define* (event key: summary dtstart dtend)
   (define ev (make-vcomponent 'VEVENT))
-  (set! (prop ev 'SUMMARY)
-    summary
-    (prop ev 'DTSTART)
-    dtstart
-    (prop ev 'DTEND)
-    dtend)
+  (set! (prop ev 'SUMMARY) summary
+        (prop ev 'DTSTART) dtstart
+        (prop ev 'DTEND) dtend)
   ev)
 
 (define start