aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/world/net
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/world/net')
-rw-r--r--stdlib/source/library/lux/world/net/http.lux80
-rw-r--r--stdlib/source/library/lux/world/net/http/client.lux227
-rw-r--r--stdlib/source/library/lux/world/net/http/cookie.lux88
-rw-r--r--stdlib/source/library/lux/world/net/http/header.lux35
-rw-r--r--stdlib/source/library/lux/world/net/http/mime.lux100
-rw-r--r--stdlib/source/library/lux/world/net/http/query.lux65
-rw-r--r--stdlib/source/library/lux/world/net/http/request.lux128
-rw-r--r--stdlib/source/library/lux/world/net/http/response.lux74
-rw-r--r--stdlib/source/library/lux/world/net/http/route.lux74
-rw-r--r--stdlib/source/library/lux/world/net/http/status.lux83
-rw-r--r--stdlib/source/library/lux/world/net/http/version.lux13
-rw-r--r--stdlib/source/library/lux/world/net/uri.lux9
12 files changed, 976 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/world/net/http.lux b/stdlib/source/library/lux/world/net/http.lux
new file mode 100644
index 000000000..8e205e2a0
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http.lux
@@ -0,0 +1,80 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [try (#+ Try)]
+ [concurrency
+ [promise (#+ Promise)]
+ [frp (#+ Channel)]]
+ [parser
+ ["." environment (#+ Environment)]]]
+ [data
+ [binary (#+ Binary)]]]]
+ [// (#+ URL)
+ [uri (#+ URI)]])
+
+(type: #export Version
+ Text)
+
+(type: #export Method
+ #Post
+ #Get
+ #Put
+ #Patch
+ #Delete
+ #Head
+ #Connect
+ #Options
+ #Trace)
+
+(type: #export Port
+ Nat)
+
+(type: #export Status
+ Nat)
+
+(type: #export Headers
+ Environment)
+
+(def: #export empty
+ Headers
+ environment.empty)
+
+(type: #export Header
+ (-> Headers Headers))
+
+(type: #export (Body !)
+ (-> (Maybe Nat) (! (Try [Nat Binary]))))
+
+(type: #export Scheme
+ #HTTP
+ #HTTPS)
+
+(type: #export Address
+ {#port Port
+ #host Text})
+
+(type: #export Identification
+ {#local Address
+ #remote Address})
+
+(type: #export Protocol
+ {#version Version
+ #scheme Scheme})
+
+(type: #export Resource
+ {#method Method
+ #uri URI})
+
+(type: #export (Message !)
+ {#headers Headers
+ #body (Body !)})
+
+(type: #export (Request !)
+ [Identification Protocol Resource (Message !)])
+
+(type: #export (Response !)
+ [Status (Message !)])
+
+(type: #export (Server !)
+ (-> (Request !) (! (Response !))))
diff --git a/stdlib/source/library/lux/world/net/http/client.lux b/stdlib/source/library/lux/world/net/http/client.lux
new file mode 100644
index 000000000..5a7a93e31
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/client.lux
@@ -0,0 +1,227 @@
+(.module:
+ [library
+ [lux #*
+ ["@" target]
+ ["." ffi]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." binary (#+ Binary)]
+ ["." maybe ("#\." functor)]
+ ["." text]
+ [collection
+ ["." dictionary]]]
+ [math
+ [number
+ ["n" nat]
+ ["i" int]]]]]
+ ["." //
+ [// (#+ URL)]])
+
+(interface: #export (Client !)
+ (: (-> //.Method URL //.Headers (Maybe Binary)
+ (! (Try (//.Response !))))
+ request))
+
+(template [<name> <method>]
+ [(def: #export (<name> url headers data client)
+ (All [!]
+ (-> URL //.Headers (Maybe Binary) (Client !)
+ (! (Try (//.Response !)))))
+ (\ client request <method> url headers data))]
+
+ [post #//.Post]
+ [get #//.Get]
+ [put #//.Put]
+ [patch #//.Patch]
+ [delete #//.Delete]
+ [head #//.Head]
+ [connect #//.Connect]
+ [options #//.Options]
+ [trace #//.Trace]
+ )
+
+(def: default_buffer_size
+ (n.* 1,024 1,024))
+
+(def: empty_body
+ [Nat Binary]
+ [0 (binary.create 0)])
+
+(def: (body_of data)
+ (-> Binary [Nat Binary])
+ [(binary.size data) data])
+
+(with_expansions [<jvm> (as_is (ffi.import: java/lang/String)
+
+ (ffi.import: java/lang/AutoCloseable
+ ["#::."
+ (close [] #io #try void)])
+
+ (ffi.import: java/io/InputStream)
+
+ (ffi.import: java/io/OutputStream
+ ["#::."
+ (flush [] #io #try void)
+ (write [[byte]] #io #try void)])
+
+ (ffi.import: java/net/URLConnection
+ ["#::."
+ (setDoOutput [boolean] #io #try void)
+ (setRequestProperty [java/lang/String java/lang/String] #io #try void)
+ (getInputStream [] #io #try java/io/InputStream)
+ (getOutputStream [] #io #try java/io/OutputStream)
+ (getHeaderFieldKey [int] #io #try #? java/lang/String)
+ (getHeaderField [int] #io #try #? java/lang/String)])
+
+ (ffi.import: java/net/HttpURLConnection
+ ["#::."
+ (setRequestMethod [java/lang/String] #io #try void)
+ (getResponseCode [] #io #try int)])
+
+ (ffi.import: java/net/URL
+ ["#::."
+ (new [java/lang/String])
+ (openConnection [] #io #try java/net/URLConnection)])
+
+ (ffi.import: java/io/BufferedInputStream
+ ["#::."
+ (new [java/io/InputStream])
+ (read [[byte] int int] #io #try int)])
+
+ (def: jvm_method
+ (-> //.Method Text)
+ (|>> (case> #//.Post "POST"
+ #//.Get "GET"
+ #//.Put "PUT"
+ #//.Patch "PATCH"
+ #//.Delete "DELETE"
+ #//.Head "HEAD"
+ #//.Connect "CONNECT"
+ #//.Options "OPTIONS"
+ #//.Trace "TRACE")))
+
+ (def: (default_body input)
+ (-> java/io/BufferedInputStream (//.Body IO))
+ (|>> (maybe\map (|>> [true]))
+ (maybe.default [false ..default_buffer_size])
+ (case> [_ 0]
+ (do (try.with io.monad)
+ [_ (java/lang/AutoCloseable::close input)]
+ (wrap ..empty_body))
+
+ [partial? buffer_size]
+ (let [buffer (binary.create buffer_size)]
+ (if partial?
+ (loop [so_far +0]
+ (do {! (try.with io.monad)}
+ [#let [remaining (i.- so_far (.int buffer_size))]
+ bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
+ (case bytes_read
+ -1 (do !
+ [_ (java/lang/AutoCloseable::close input)]
+ (wrap [(.nat so_far) buffer]))
+ +0 (recur so_far)
+ _ (if (i.= remaining bytes_read)
+ (wrap [buffer_size buffer])
+ (recur (i.+ bytes_read so_far))))))
+ (loop [so_far +0
+ output (\ binary.monoid identity)]
+ (do {! (try.with io.monad)}
+ [#let [remaining (i.- so_far (.int buffer_size))]
+ bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)]
+ (case bytes_read
+ -1 (do !
+ [_ (java/lang/AutoCloseable::close input)]
+ (case so_far
+ +0 (wrap (..body_of output))
+ _ (|> buffer
+ (binary.slice 0 (.nat so_far))
+ (\ try.functor map
+ (|>> (\ binary.monoid compose output)
+ ..body_of))
+ (\ io.monad wrap))))
+ +0 (recur so_far output)
+ _ (if (i.= remaining bytes_read)
+ (recur +0
+ (\ binary.monoid compose output buffer))
+ (recur (i.+ bytes_read so_far)
+ output))))))))))
+
+ (def: (default_headers connection)
+ (-> java/net/HttpURLConnection (IO (Try //.Headers)))
+ (loop [index +0
+ headers //.empty]
+ (do {! (try.with io.monad)}
+ [?name (java/net/URLConnection::getHeaderFieldKey index connection)]
+ (case ?name
+ (#.Some name)
+ (do !
+ [?value (java/net/URLConnection::getHeaderField index connection)]
+ (recur (inc index)
+ (dictionary.put name (maybe.default "" ?value) headers)))
+
+ #.None
+ (wrap headers)))))
+
+ (implementation: #export default
+ (Client IO)
+
+ (def: (request method url headers data)
+ (: (IO (Try (//.Response IO)))
+ (do {! (try.with io.monad)}
+ [connection (|> url java/net/URL::new java/net/URL::openConnection)
+ #let [connection (:as java/net/HttpURLConnection connection)]
+ _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection)
+ _ (monad.map ! (function (_ [name value])
+ (java/net/URLConnection::setRequestProperty name value connection))
+ (dictionary.entries headers))
+ _ (case data
+ (#.Some data)
+ (do !
+ [_ (java/net/URLConnection::setDoOutput true connection)
+ stream (java/net/URLConnection::getOutputStream connection)
+ _ (java/io/OutputStream::write data stream)
+ _ (java/io/OutputStream::flush stream)
+ _ (java/lang/AutoCloseable::close stream)]
+ (wrap []))
+
+ #.None
+ (wrap []))
+ status (java/net/HttpURLConnection::getResponseCode connection)
+ headers (..default_headers connection)
+ input (|> connection
+ java/net/URLConnection::getInputStream
+ (\ ! map (|>> java/io/BufferedInputStream::new)))]
+ (wrap [(.nat status)
+ {#//.headers headers
+ #//.body (..default_body input)}]))))))]
+ (for {@.old (as_is <jvm>)
+ @.jvm (as_is <jvm>)}
+ (as_is)))
+
+(implementation: #export (async client)
+ (-> (Client IO) (Client Promise))
+
+ (def: (request method url headers data)
+ (|> (\ client request method url headers data)
+ promise.future
+ (\ promise.monad map
+ (|>> (case> (#try.Success [status message])
+ (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise))
+ (function (_ body)
+ (|>> body promise.future)))
+ message)])
+
+ (#try.Failure error)
+ (#try.Failure error)))))))
+
+(def: #export headers
+ (-> (List [Text Text]) //.Headers)
+ (dictionary.from_list text.hash))
diff --git a/stdlib/source/library/lux/world/net/http/cookie.lux b/stdlib/source/library/lux/world/net/http/cookie.lux
new file mode 100644
index 000000000..08a75fecc
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/cookie.lux
@@ -0,0 +1,88 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["." try (#+ Try)]
+ ["p" parser ("#\." monad)
+ ["l" text (#+ Parser)]]]
+ [data
+ [number
+ ["i" int]]
+ [text
+ ["%" format (#+ format)]]
+ [format
+ ["." context (#+ Context)]]
+ [collection
+ ["." dictionary]]]
+ [time
+ ["." duration (#+ Duration)]]]]
+ ["." // (#+ Header)
+ ["." header]])
+
+(type: #export Directive (-> Text Text))
+
+(def: (directive extension)
+ (-> Text Directive)
+ (function (_ so-far)
+ (format so-far "; " extension)))
+
+(def: #export (set name value)
+ (-> Text Text Header)
+ (header.add "Set-Cookie" (format name "=" value)))
+
+(def: #export (max-age duration)
+ (-> Duration Directive)
+ (let [seconds (duration.query duration.second duration)]
+ (..directive (format "Max-Age=" (if (i.< +0 seconds)
+ (%.int seconds)
+ (%.nat (.nat seconds)))))))
+
+(template [<name> <prefix>]
+ [(def: #export (<name> value)
+ (-> Text Directive)
+ (..directive (format <prefix> "=" value)))]
+
+ [domain "Domain"]
+ [path "Path"]
+ )
+
+(template [<name> <tag>]
+ [(def: #export <name>
+ Directive
+ (..directive <tag>))]
+
+ [secure "Secure"]
+ [http-only "HttpOnly"]
+ )
+
+(type: #export CSRF-Policy
+ #Strict
+ #Lax)
+
+(def: #export (same-site policy)
+ (-> CSRF-Policy Directive)
+ (..directive (format "SameSite=" (case policy
+ #Strict "Strict"
+ #Lax "Lax"))))
+
+(def: (cookie context)
+ (-> Context (Parser Context))
+ (do p.monad
+ [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 (Parser Context))
+ ($_ p.either
+ (do p.monad
+ [context' (..cookie context)
+ _ (l.this "; ")]
+ (cookies context'))
+ (p\wrap context)))
+
+(def: #export (get header)
+ (-> Text (Try Context))
+ (l.run header (..cookies context.empty)))
diff --git a/stdlib/source/library/lux/world/net/http/header.lux b/stdlib/source/library/lux/world/net/http/header.lux
new file mode 100644
index 000000000..e5b1882ad
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/header.lux
@@ -0,0 +1,35 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ [pipe (#+ case>)]]
+ [data
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]]
+ [// (#+ Header)
+ ["." mime (#+ MIME)]
+ [// (#+ URL)]])
+
+(def: #export (add name value)
+ (-> Text Text Header)
+ (dictionary.upsert name ""
+ (|>> (case>
+ ""
+ value
+
+ previous
+ (format previous "," value)))))
+
+(def: #export content-length
+ (-> Nat Header)
+ (|>> %.nat (..add "Content-Length")))
+
+(def: #export content-type
+ (-> MIME Header)
+ (|>> mime.name (..add "Content-Type")))
+
+(def: #export location
+ (-> URL Header)
+ (..add "Location"))
diff --git a/stdlib/source/library/lux/world/net/http/mime.lux b/stdlib/source/library/lux/world/net/http/mime.lux
new file mode 100644
index 000000000..859b0840e
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/mime.lux
@@ -0,0 +1,100 @@
+(.module:
+ [library
+ [lux #*
+ [data
+ ["." text
+ ["%" format (#+ format)]
+ ["." encoding (#+ Encoding)]]]
+ [type
+ abstract]]])
+
+(abstract: #export MIME
+ Text
+
+ {#doc "Multipurpose Internet Mail Extensions"}
+
+ (def: #export mime
+ (-> Text MIME)
+ (|>> :abstraction))
+
+ (def: #export name
+ (-> MIME Text)
+ (|>> :representation))
+ )
+
+## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types
+(template [<name> <type>]
+ [(def: #export <name> MIME (..mime <type>))]
+
+ [aac-audio "audio/aac"]
+ [abiword "application/x-abiword"]
+ [avi "video/x-msvideo"]
+ [amazon-kindle-ebook "application/vnd.amazon.ebook"]
+ [binary "application/octet-stream"]
+ [bitmap "image/bmp"]
+ [bzip "application/x-bzip"]
+ [bzip2 "application/x-bzip2"]
+ [c-shell "application/x-csh"]
+ [css "text/css"]
+ [csv "text/csv"]
+ [microsoft-word "application/msword"]
+ [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"]
+ [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"]
+ [epub "application/epub+zip"]
+ [ecmascript "application/ecmascript"]
+ [gif "image/gif"]
+ [html "text/html"]
+ [icon "image/x-icon"]
+ [icalendar "text/calendar"]
+ [jar "application/java-archive"]
+ [jpeg "image/jpeg"]
+ [javascript "application/javascript"]
+ [json "application/json"]
+ [midi "audio/midi"]
+ [mpeg "video/mpeg"]
+ [apple-installer-package "application/vnd.apple.installer+xml"]
+ [opendocument-presentation "application/vnd.oasis.opendocument.presentation"]
+ [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"]
+ [opendocument-text "application/vnd.oasis.opendocument.text"]
+ [ogg-audio "audio/ogg"]
+ [ogg-video "video/ogg"]
+ [ogg "application/ogg"]
+ [opentype-font "font/otf"]
+ [png "image/png"]
+ [pdf "application/pdf"]
+ [microsoft-powerpoint "application/vnd.ms-powerpoint"]
+ [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"]
+ [rar "application/x-rar-compressed"]
+ [rtf "application/rtf"]
+ [bourne-shell "application/x-sh"]
+ [svg "image/svg+xml"]
+ [flash "application/x-shockwave-flash"]
+ [tar "application/x-tar"]
+ [tiff "image/tiff"]
+ [typescript "application/typescript"]
+ [truetype-font "font/ttf"]
+ [microsoft-visio "application/vnd.visio"]
+ [wav "audio/wav"]
+ [webm-audio "audio/webm"]
+ [webm-video "video/webm"]
+ [webp "image/webp"]
+ [woff "font/woff"]
+ [woff2 "font/woff2"]
+ [xhtml "application/xhtml+xml"]
+ [microsoft-excel "application/vnd.ms-excel"]
+ [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"]
+ [xml "application/xml"]
+ [xul "application/vnd.mozilla.xul+xml"]
+ [zip "application/zip"]
+ [!3gpp-audio "audio/3gpp"]
+ [!3gpp "video/3gpp"]
+ [!3gpp2-audio "audio/3gpp2"]
+ [!3gpp2 "video/3gpp2"]
+ [!7z "application/x-7z-compressed"]
+ )
+
+(def: #export (text encoding)
+ (-> Encoding MIME)
+ (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote)))
+
+(def: #export utf-8 MIME (..text encoding.utf-8))
diff --git a/stdlib/source/library/lux/world/net/http/query.lux b/stdlib/source/library/lux/world/net/http/query.lux
new file mode 100644
index 000000000..b6b8936b7
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/query.lux
@@ -0,0 +1,65 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ pipe
+ [monad (#+ do)]
+ ["." try (#+ Try)]
+ ["p" parser
+ ["l" text (#+ Parser)]]]
+ [data
+ [number
+ ["." nat]]
+ ["." text
+ ["%" format (#+ format)]]
+ [format
+ ["." context (#+ Context)]]
+ [collection
+ ["." dictionary]]]]])
+
+(def: component
+ (Parser Text)
+ (p.rec
+ (function (_ component)
+ (do {! p.monad}
+ [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 nat.hex)
+ (\ ! map text.from-code))
+ tail component]
+ (wrap (format head code tail))))))))
+
+(def: (form context)
+ (-> Context (Parser Context))
+ ($_ p.either
+ (do p.monad
+ [_ l.end]
+ (wrap context))
+ (do {! p.monad}
+ [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 wrap context)))
+
+(def: #export (parameters raw)
+ (-> Text (Try Context))
+ (l.run raw (..form context.empty)))
diff --git a/stdlib/source/library/lux/world/net/http/request.lux b/stdlib/source/library/lux/world/net/http/request.lux
new file mode 100644
index 000000000..4a6911798
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/request.lux
@@ -0,0 +1,128 @@
+(.module:
+ [library
+ [lux #*
+ [control
+ pipe
+ ["." monad (#+ do)]
+ ["." try (#+ Try)]
+ [concurrency
+ ["." promise (#+ Promise)]
+ ["." frp]]
+ [parser
+ ["<.>" json]]]
+ [data
+ ["." maybe]
+ ["." number
+ ["n" nat]]
+ ["." text
+ ["." encoding]]
+ [format
+ ["." json (#+ JSON)]
+ ["." context (#+ Context Property)]]
+ [collection
+ ["." list ("#\." functor fold)]
+ ["." dictionary]]]
+ [world
+ ["." binary (#+ Binary)]]]]
+ ["." // (#+ Body Response Server)
+ ["#." response]
+ ["#." query]
+ ["#." cookie]])
+
+(def: (merge inputs)
+ (-> (List Binary) Binary)
+ (let [[_ output] (try.assume
+ (monad.fold try.monad
+ (function (_ input [offset output])
+ (let [amount (binary.size input)]
+ (\ try.functor 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 (Try Text)))
+ (do promise.monad
+ [blobs (frp.consume body)]
+ (wrap (\ encoding.utf8 decode (merge blobs)))))
+
+(def: failure (//response.bad-request ""))
+
+(def: #export (json reader server)
+ (All [a] (-> (<json>.Reader a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?raw (read-text-body (get@ #//.body message))]
+ (case (do try.monad
+ [raw ?raw
+ content (\ json.codec decode raw)]
+ (json.run content reader))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (text server)
+ (-> (-> Text Server) Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?raw (read-text-body (get@ #//.body message))]
+ (case ?raw
+ (#try.Success content)
+ (server content request)
+
+ (#try.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 try.monad
+ [query (//query.parameters query)
+ input (context.run query property)]
+ (wrap [[identification protocol (set@ #//.uri uri resource) message]
+ input]))
+ (#try.Success [request input])
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (form property server)
+ (All [a] (-> (Property a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (do promise.monad
+ [?body (read-text-body (get@ #//.body message))]
+ (case (do try.monad
+ [body ?body
+ form (//query.parameters body)]
+ (context.run form property))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure)))))
+
+(def: #export (cookies property server)
+ (All [a] (-> (Property a) (-> a Server) Server))
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (do try.monad
+ [cookies (|> (get@ #//.headers message)
+ (dictionary.get "Cookie")
+ (maybe.default "")
+ //cookie.get)]
+ (context.run cookies property))
+ (#try.Success input)
+ (server input request)
+
+ (#try.Failure error)
+ (promise.resolved ..failure))))
diff --git a/stdlib/source/library/lux/world/net/http/response.lux b/stdlib/source/library/lux/world/net/http/response.lux
new file mode 100644
index 000000000..0ca825a44
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/response.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux (#- static)
+ [control
+ [concurrency
+ ["." promise]
+ ["." frp ("#\." monad)]]]
+ [data
+ ["." text
+ ["." encoding]]
+ [format
+ ["." html]
+ ["." css (#+ CSS)]
+ ["." context]
+ ["." json (#+ JSON) ("#\." codec)]]]
+ ["." io]
+ [world
+ ["." binary (#+ Binary)]]]]
+ ["." // (#+ Status Body Response Server)
+ ["." status]
+ ["." mime (#+ MIME)]
+ ["." header]
+ [// (#+ URL)]])
+
+(def: #export (static response)
+ (-> Response Server)
+ (function (_ request)
+ (promise.resolved response)))
+
+(def: #export empty
+ (-> Status Response)
+ (let [body (frp\wrap (\ encoding.utf8 encode ""))]
+ (function (_ status)
+ [status
+ {#//.headers (|> context.empty
+ (header.content-length 0)
+ (header.content-type mime.utf-8))
+ #//.body body}])))
+
+(def: #export (temporary-redirect to)
+ (-> URL Response)
+ (let [[status message] (..empty status.temporary-redirect)]
+ [status (update@ #//.headers (header.location to) message)]))
+
+(def: #export not-found
+ Response
+ (..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 (frp\wrap data)}])
+
+(def: #export bad-request
+ (-> Text Response)
+ (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8)))
+
+(def: #export ok
+ (-> MIME Binary Response)
+ (content status.ok))
+
+(template [<name> <type> <mime> <pre>]
+ [(def: #export <name>
+ (-> <type> Response)
+ (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))]
+
+ [text Text mime.utf-8 (<|)]
+ [html html.Document mime.html html.html]
+ [css CSS mime.css css.css]
+ [json JSON mime.json json\encode]
+ )
diff --git a/stdlib/source/library/lux/world/net/http/route.lux b/stdlib/source/library/lux/world/net/http/route.lux
new file mode 100644
index 000000000..456ed9e36
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/route.lux
@@ -0,0 +1,74 @@
+(.module:
+ [library
+ [lux (#- or)
+ [control
+ [monad (#+ do)]
+ [concurrency
+ ["." promise]]]
+ [data
+ ["." maybe]
+ ["." text]
+ [number
+ ["n" nat]]]]]
+ ["." // (#+ URI Server)
+ ["#." status]
+ ["#." response]])
+
+(template [<scheme> <name>]
+ [(def: #export (<name> server)
+ (-> Server Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (get@ #//.scheme protocol)
+ <scheme>
+ (server request)
+
+ _
+ (promise.resolved //response.not-found))))]
+
+ [#//.HTTP http]
+ [#//.HTTPS https]
+ )
+
+(template [<method> <name>]
+ [(def: #export (<name> server)
+ (-> Server Server)
+ (function (_ (^@ request [identification protocol resource message]))
+ (case (get@ #//.method resource)
+ <method>
+ (server request)
+
+ _
+ (promise.resolved //response.not-found))))]
+
+ [#//.Get get]
+ [#//.Post post]
+ [#//.Put put]
+ [#//.Patch patch]
+ [#//.Delete delete]
+ [#//.Head head]
+ [#//.Connect connect]
+ [#//.Options options]
+ [#//.Trace trace]
+ )
+
+(def: #export (uri path server)
+ (-> URI Server Server)
+ (function (_ [identification protocol resource message])
+ (if (text.starts-with? path (get@ #//.uri resource))
+ (server [identification
+ protocol
+ (update@ #//.uri
+ (|>> (text.clip' (text.size path)) maybe.assume)
+ resource)
+ message])
+ (promise.resolved //response.not-found))))
+
+(def: #export (or primary alternative)
+ (-> Server Server Server)
+ (function (_ request)
+ (do promise.monad
+ [response (primary request)
+ #let [[status message] response]]
+ (if (n.= //status.not-found status)
+ (alternative request)
+ (wrap response)))))
diff --git a/stdlib/source/library/lux/world/net/http/status.lux b/stdlib/source/library/lux/world/net/http/status.lux
new file mode 100644
index 000000000..fe3f7d90d
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/status.lux
@@ -0,0 +1,83 @@
+(.module:
+ [library
+ [lux #*]]
+ [// (#+ Status)])
+
+## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes
+(template [<status> <name>]
+ [(def: #export <name>
+ Status
+ <status>)]
+
+ ## 1xx Informational response
+ [100 continue]
+ [101 switching_protocols]
+ [102 processing]
+ [103 early_hints]
+
+ ## 2xx Success
+ [200 ok]
+ [201 created]
+ [202 accepted]
+ [203 non_authoritative_information]
+ [204 no_content]
+ [205 reset_content]
+ [206 partial_content]
+ [207 multi_status]
+ [208 already_reported]
+ [226 im_used]
+
+ ## 3xx Redirection
+ [300 multiple_choices]
+ [301 moved_permanently]
+ [302 found]
+ [303 see_other]
+ [304 not_modified]
+ [305 use_proxy]
+ [306 switch_proxy]
+ [307 temporary_redirect]
+ [308 permanent_redirect]
+
+ ## 4xx Client errors
+ [400 bad_request]
+ [401 unauthorized]
+ [402 payment_required]
+ [403 forbidden]
+ [404 not_found]
+ [405 method_not_allowed]
+ [406 not_acceptable]
+ [407 proxy_authentication_required]
+ [408 request_timeout]
+ [409 conflict]
+ [410 gone]
+ [411 length_required]
+ [412 precondition_failed]
+ [413 payload_too_large]
+ [414 uri_too_long]
+ [415 unsupported_media_type]
+ [416 range_not_satisfiable]
+ [417 expectation_failed]
+ [418 im_a_teapot]
+ [421 misdirected_request]
+ [422 unprocessable_entity]
+ [423 locked]
+ [424 failed_dependency]
+ [426 upgrade_required]
+ [428 precondition_required]
+ [429 too_many_requests]
+ [431 request_header_fields_too_large]
+ [451 unavailable_for_legal_reasons]
+
+ ## 5xx Server errors
+ [500 internal_server_error]
+ [501 not_implemented]
+ [502 bad_gateway]
+ [503 service_unavailable]
+ [504 gateway_timeout]
+ [505 http_version_not_supported]
+ [506 variant_also_negotiates]
+ [507 insufficient_storage]
+ [508 loop_detected]
+ [510 not_extended]
+ [511 network_authentication_required]
+ )
diff --git a/stdlib/source/library/lux/world/net/http/version.lux b/stdlib/source/library/lux/world/net/http/version.lux
new file mode 100644
index 000000000..2443fda12
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/http/version.lux
@@ -0,0 +1,13 @@
+(.module:
+ [library
+ [lux #*]]
+ [// (#+ Version)])
+
+(template [<name> <version>]
+ [(def: #export <name> Version <version>)]
+
+ [v0_9 "0.9"]
+ [v1_0 "1.0"]
+ [v1_1 "1.1"]
+ [v2_0 "2.0"]
+ )
diff --git a/stdlib/source/library/lux/world/net/uri.lux b/stdlib/source/library/lux/world/net/uri.lux
new file mode 100644
index 000000000..2c43cbbd3
--- /dev/null
+++ b/stdlib/source/library/lux/world/net/uri.lux
@@ -0,0 +1,9 @@
+(.module:
+ [library
+ [lux #*]])
+
+(type: #export URI
+ Text)
+
+(def: #export separator
+ "/")
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 02:19:17 +0000