diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/world/binary.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/world/net/http/cookie.lux | 32 | ||||
| -rw-r--r-- | stdlib/source/lux/world/net/http/query.lux | 63 | ||||
| -rw-r--r-- | stdlib/source/lux/world/net/http/request.lux | 128 | ||||
| -rw-r--r-- | stdlib/source/lux/world/net/http/response.lux | 78 |
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))) |