From bf1c66ffd8686f9fb78210c002e21cfa27a33504 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Wed, 22 May 2019 23:11:06 +0200
Subject: Server add POST body parameters, and state forwarding.

---
 module/server/macro.scm | 26 +++++++++++++++++++-------
 module/server/test.scm  | 23 +++++++++--------------
 2 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/module/server/macro.scm b/module/server/macro.scm
index 951e009d..f920a663 100644
--- a/module/server/macro.scm
+++ b/module/server/macro.scm
@@ -51,7 +51,8 @@
                      (cdr (iota (1+ (length intersect)))))))))))
 
 (define-macro (make-routes . routes)
-  `(lambda (request body)
+
+  `(lambda (request body . state)
      (let ((r:method  (request-method  request))
            (r:uri     (request-uri     request))
            (r:version (request-version request))
@@ -65,9 +66,20 @@
              (r:path     (uri-path     r:uri))
              (r:query    (uri-query    r:uri))
              (r:fragment (uri-fragment r:uri)))
-         (call/ec (lambda (return)
-                    (apply
-                     (cond ,@(map generate-case routes)
-                           (else (lambda* _ (return (build-response #:code 404)
-                                                    "404 Not Fonud"))))
-                     (parse-query r:query))))))))
+
+
+         (call-with-values
+             (lambda ()
+              (call/ec (lambda (return)
+                         (apply
+                          (cond ,@(map generate-case routes)
+                                (else (lambda* _ (return (build-response #:code 404)
+                                                         "404 Not Fonud"))))
+                          (append
+                           (parse-query r:query)
+
+                           (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)))))))))
diff --git a/module/server/test.scm b/module/server/test.scm
index 33951695..f28b1152 100644
--- a/module/server/test.scm
+++ b/module/server/test.scm
@@ -12,15 +12,14 @@
              (server macro)
 
              (ice-9 iconv)
+             (srfi srfi-88)
 
              (sxml simple)
              (ice-9 ftw))
 
-(define *name* "")
-
-(define (form-page)
+(define (form-page name)
   `(div
-    (p "hello" ,*name*)
+    (p "Hello " ,name)
     (form (@ (action "/form")
              (method POST))
           (input (@ (type text)
@@ -42,18 +41,13 @@
    (GET "/form" ()
         (return
          '((content-type text/html))
-         (sxml->xml-string (form-page))))
-
-   (POST "/form" ()
-         (when (memv 'application/x-www-form-urlencoded (assoc-ref r:headers 'content-type))
-           (apply (lambda* (#:key name #:allow-other-keys)
-                    (format #t "*name* := [~a] Received [~a]~%" *name* name)
-                    (set! *name* name))
-                  (parse-query (uri-decode (bytevector->string body "UTF-8")))))
+         (sxml->xml-string (form-page state))))
+
+   (POST "/form" (name)
          (return (build-response
                   #:code 303
                   #:headers `((location . ,(string->uri-reference "/form"))))
-                 ""))
+                 "" name))
 
 
    (GET "/ls" ()
@@ -77,4 +71,5 @@
                 (call-with-input-file (string-append "./" file)
                   (@ (ice-9 rdelim) read-string))))))
 
-(run-server routes)
+(run-server routes 'http '() "Default Name")
+
-- 
cgit v1.2.3