aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/world/binary.lux4
-rw-r--r--stdlib/source/lux/world/net/http/cookie.lux32
-rw-r--r--stdlib/source/lux/world/net/http/query.lux63
-rw-r--r--stdlib/source/lux/world/net/http/request.lux128
-rw-r--r--stdlib/source/lux/world/net/http/response.lux78
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)))