Adding machinery for processing HTTP requests.

5 files changed, 264 insertions, 41 deletions

diff --git a/stdlib/source/lux/world/binary.lux b/stdlib/source/lux/world/binary.lux
index 7f3e3123d..8e5b3901d 100644
--- a/stdlib/source/lux/world/binary.lux
+++ b/stdlib/source/lux/world/binary.lux
@@ -3,7 +3,7 @@
    [control
     [monad (#+ do)]
     ["ex" exception (#+ exception:)]
-    ["eq" equivalence]]
+    [equivalence (#+ Equivalence)]]
    [data
     ["." maybe]
     ["." error (#+ Error)]
@@ -159,7 +159,7 @@
   (-> Nat Binary (Error Binary))
   (slice from (dec (..!size binary)) binary))
 
-(structure: #export _ (eq.Equivalence Binary)
+(structure: #export _ (Equivalence Binary)
   (def: (= reference sample)
     (Arrays::equals reference sample)))
 
diff --git a/stdlib/source/lux/world/net/http/cookie.lux b/stdlib/source/lux/world/net/http/cookie.lux
index 757d2abc8..d6b0c979d 100644
--- a/stdlib/source/lux/world/net/http/cookie.lux
+++ b/stdlib/source/lux/world/net/http/cookie.lux
@@ -1,8 +1,17 @@
 (.module:
   [lux #*
+   [control
+    [monad (#+ do)]
+    ["p" parser ("p/." Monad<Parser>)]]
    [data
+    ["." error (#+ Error)]
     [text
-     format]]
+     format
+     ["l" lexer (#+ Lexer)]]
+    [format
+     ["." context (#+ Context)]]
+    [collection
+     ["." dictionary]]]
    [time
     ["." duration (#+ Duration)]]]
   ["." // (#+ Header)
@@ -53,3 +62,24 @@
   (..directive (format "SameSite=" (case policy
                                      #Strict "Strict"
                                      #Lax "Lax"))))
+
+(def: (cookie context)
+  (-> Context (Lexer Context))
+  (do p.Monad<Parser>
+    [key (l.slice (l.many! (l.none-of! "=")))
+     _ (l.this "=")
+     value (l.slice (l.many! (l.none-of! ";")))]
+    (wrap (dictionary.put key value context))))
+
+(def: (cookies context)
+  (-> Context (Lexer Context))
+  ($_ p.either
+      (do p.Monad<Parser>
+        [context' (..cookie context)
+         _ (l.this "; ")]
+        (cookies context'))
+      (p/wrap context)))
+
+(def: #export (get header)
+  (-> Text (Error Context))
+  (l.run header (..cookies context.empty)))
diff --git a/stdlib/source/lux/world/net/http/query.lux b/stdlib/source/lux/world/net/http/query.lux
new file mode 100644
index 000000000..7d736f46e
--- /dev/null
+++ b/stdlib/source/lux/world/net/http/query.lux
@@ -0,0 +1,63 @@
+(.module:
+  [lux #*
+   [control
+    pipe
+    [monad (#+ do)]
+    ["p" parser]]
+   [data
+    ["." error (#+ Error)]
+    ["." number]
+    ["." text
+     format
+     ["l" lexer (#+ Lexer)]]
+    [format
+     ["." context (#+ Context)]]
+    [collection
+     ["." dictionary]]]])
+
+(def: component
+  (Lexer Text)
+  (p.rec
+   (function (_ component)
+     (do p.Monad<Parser>
+       [head (l.some (l.none-of "+%&;"))]
+       ($_ p.either
+           (p.after (p.either l.end
+                              (l.this "&"))
+                    (wrap head))
+           (do @
+             [_ (l.this "+")
+              tail component]
+             (wrap (format head " " tail)))
+           (do @
+             [_ (l.this "%")
+              code (|> (l.exactly 2 l.hexadecimal)
+                       (p.codec number.Hex@Codec<Text,Nat>)
+                       (:: @ map text.from-code))
+              tail component]
+             (wrap (format head code tail))))))))
+
+(def: (form context)
+  (-> Context (Lexer Context))
+  ($_ p.either
+      (do p.Monad<Parser>
+        [_ l.end]
+        (wrap context))
+      (do p.Monad<Parser>
+        [key (l.some (l.none-of "=&;"))
+         key (l.local key ..component)]
+        (p.either (do @
+                    [_ (l.this "=")
+                     value ..component]
+                    (form (dictionary.put key value context)))
+                  (do @
+                    [_ ($_ p.or
+                           (l.one-of "&;")
+                           l.end)]
+                    (form (dictionary.put key "" context)))))
+      ## if invalid form data, just stop parsing...
+      (:: p.Monad<Parser> wrap context)))
+
+(def: #export (parameters raw)
+  (-> Text (Error Context))
+  (l.run raw (..form context.empty)))
diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux
new file mode 100644
index 000000000..fd09628a5
--- /dev/null
+++ b/stdlib/source/lux/world/net/http/request.lux
@@ -0,0 +1,128 @@
+(.module:
+  [lux #*
+   [control
+    pipe
+    ["." monad (#+ do)]
+    [concurrency
+     ["." promise (#+ Promise)]
+     ["." frp]]]
+   [data
+    ["." maybe]
+    ["." error (#+ Error)]
+    ["." number]
+    ["." text
+     format
+     ["." encoding]]
+    [format
+     ["." json (#+ JSON)]
+     ["." context (#+ Context Property)]]
+    [collection
+     [list ("list/." Functor<List> Fold<List>)]
+     ["." dictionary]]]
+   [world
+    ["." binary (#+ Binary)]]]
+  ["." // (#+ Body Response Server)
+   ["//." response]
+   ["//." query]
+   ["//." cookie]])
+
+(def: (merge inputs)
+  (-> (List Binary) Binary)
+  (let [[_ output] (error.assume
+                    (monad.fold error.Monad<Error>
+                                (function (_ input [offset output])
+                                  (let [amount (binary.size input)]
+                                    (:: error.Functor<Error> map (|>> [(n/+ amount offset)])
+                                        (binary.copy amount 0 input offset output))))
+                                [0 (|> inputs
+                                       (list/map binary.size)
+                                       (list/fold n/+ 0)
+                                       binary.create)]
+                                inputs))]
+    output))
+
+(def: (read-text-body body)
+  (-> Body (Promise (Error Text)))
+  (do promise.Monad<Promise>
+    [blobs (frp.consume body)]
+    (wrap (encoding.from-utf8 (merge blobs)))))
+
+(def: failure (//response.bad-request ""))
+
+(def: #export (json server)
+  (-> (-> JSON Server) Server)
+  (function (_ request)
+    (let [[identification protocol resource message] request]
+      (do promise.Monad<Promise>
+        [?raw (read-text-body (get@ #//.body message))]
+        (case (do error.Monad<Error>
+                [raw ?raw]
+                (:: json.Codec<Text,JSON> decode raw))
+          (#error.Success content)
+          (server content request)
+          
+          (#error.Failure error)
+          (promise.resolved ..failure))))))
+
+(def: #export (text server)
+  (-> (-> Text Server) Server)
+  (function (_ request)
+    (let [[identification protocol resource message] request]
+      (do promise.Monad<Promise>
+        [?raw (read-text-body (get@ #//.body message))]
+        (case ?raw
+          (#error.Success content)
+          (server content request)
+          
+          (#error.Failure error)
+          (promise.resolved ..failure))))))
+
+(def: #export (query property server)
+  (All [a] (-> (Property a) (-> a Server) Server))
+  (function (_ [identification protocol resource message])
+    (let [full (get@ #//.uri resource)
+          [uri query] (|> full
+                          (text.split-with "?")
+                          (maybe.default [full ""]))]
+      (case (do error.Monad<Error>
+              [query (//query.parameters query)
+               input (context.run query property)]
+              (wrap [[identification protocol (set@ #//.uri uri resource) message]
+                     input]))
+        (#error.Success [request input])
+        (server input request)
+        
+        (#error.Failure error)
+        (promise.resolved ..failure)))))
+
+(def: #export (form property server)
+  (All [a] (-> (Property a) (-> a Server) Server))
+  (function (_ request)
+    (let [[identification protocol resource message] request]
+      (do promise.Monad<Promise>
+        [?body (read-text-body (get@ #//.body message))]
+        (case (do error.Monad<Error>
+                [body ?body
+                 form (//query.parameters body)]
+                (context.run form property))
+          (#error.Success input)
+          (server input request)
+          
+          (#error.Failure error)
+          (promise.resolved ..failure))))))
+
+(def: #export (cookies property server)
+  (All [a] (-> (Property a) (-> a Server) Server))
+  (function (_ request)
+    (let [[identification protocol resource message] request]
+      (case (do error.Monad<Error>
+              [cookies (|> (get@ #//.headers message)
+                           (dictionary.get "Cookie")
+                           (maybe.default "")
+                           //cookie.get)]
+              (context.run cookies property))
+        (#error.Success input)
+        (server input request)
+        
+        (#error.Failure error)
+        (promise.resolved ..failure)))))
diff --git a/stdlib/source/lux/world/net/http/response.lux b/stdlib/source/lux/world/net/http/response.lux
index 624b0167c..33bf821d5 100644
--- a/stdlib/source/lux/world/net/http/response.lux
+++ b/stdlib/source/lux/world/net/http/response.lux
@@ -8,59 +8,61 @@
      format
      ["." encoding]]
     [format
-     ["." html (#+ HTML)]]
-    [collection
-     ["." array]
-     ["." dictionary (#+ Dictionary)]]]
+     ["." html (#+ HTML)]
+     ["." css (#+ CSS)]
+     ["." context]]]
    ["." io]
    [world
     ["." binary (#+ Binary)]]]
-  ["." // (#+ Body Response)
+  ["." // (#+ Status Body Response)
    ["." status]
-   ["." mime]
+   ["." mime (#+ MIME)]
    ["." header]
    [// (#+ URL)]])
 
+(def: #export empty
+  (-> Status Response)
+  (let [body (channel/wrap (encoding.to-utf8 ""))]
+    (function (_ status)
+      [status
+       {#//.headers (|> context.empty
+                        (header.content-length 0)
+                        (header.content-type mime.text))
+        #//.body body}])))
+
 (def: #export (temporary-redirect to)
   (-> URL Response)
-  [status.temporary-redirect
-   {#//.headers (|> (dictionary.new text.Hash<Text>)
-                    (header.content-length 0)
-                    (header.content-type mime.text)
-                    (header.location to))
-    #//.body (channel/wrap (encoding.to-utf8 ""))}])
+  (let [[status message] (..empty status.temporary-redirect)]
+    [status (update@ #//.headers (header.location to) message)]))
 
 (def: #export not-found
   Response
-  [status.not-found
-   {#//.headers (|> (dictionary.new text.Hash<Text>)
-                    (header.content-length 0)
-                    (header.content-type mime.text))
-    #//.body (channel/wrap (encoding.to-utf8 ""))}])
+  (..empty status.not-found))
+
+(def: #export (content status type data)
+  (-> Status MIME Binary Response)
+  [status
+   {#//.headers (|> context.empty
+                    (header.content-length (binary.size data))
+                    (header.content-type type))
+    #//.body (channel/wrap data)}])
 
-(def: #export (fail message)
+(def: #export bad-request
   (-> Text Response)
-  (let [data (encoding.to-utf8 message)]
-    [status.bad-request
-     {#//.headers (|> (dictionary.new text.Hash<Text>)
-                      (header.content-length (binary.size data))
-                      (header.content-type mime.text))
-      #//.body (channel/wrap data)}]))
+  (|>> encoding.to-utf8 (content status.bad-request mime.text)))
 
-(def: #export (text content)
+(def: #export ok
+  (-> MIME Binary Response)
+  (content status.ok))
+
+(def: #export text
   (-> Text Response)
-  (let [data (encoding.to-utf8 content)]
-    [status.ok
-     {#//.headers (|> (dictionary.new text.Hash<Text>)
-                      (header.content-length (binary.size data))
-                      (header.content-type mime.text))
-      #//.body (channel/wrap data)}]))
+  (|>> encoding.to-utf8 (..ok mime.text)))
 
-(def: #export (html content)
+(def: #export html
   (-> (HTML Any) Response)
-  (let [data (encoding.to-utf8 (html.html content))]
-    [status.ok
-     {#//.headers (|> (dictionary.new text.Hash<Text>)
-                      (header.content-length (binary.size data))
-                      (header.content-type mime.html))
-      #//.body (channel/wrap data)}]))
+  (|>> html.html encoding.to-utf8 (..ok mime.html)))
+
+(def: #export css
+  (-> CSS Response)
+  (|>> encoding.to-utf8 (..ok mime.css)))