git.iko.soy/purestack-dev/purescript-purestack-server
on master help sign in
swap
599c6d52 ahead, 0 behind
spago.dhall+7
since splitsnapshots
unifiedsplit
@@ -6,14 +6,21 @@
6 , "arrays"
6 , "arrays"
7 , "console"
7 , "console"
8 , "control"
8 , "control"
9+ , "datetime"
9 , "effect"
10 , "effect"
10 , "either"
11 , "either"
11 , "foldable-traversable"
12 , "foldable-traversable"
13+ , "foreign-object"
14+ , "formatters"
12 , "integers"
15 , "integers"
16+ , "lists"
13 , "maybe"
17 , "maybe"
18+ , "now"
14 , "numbers"
19 , "numbers"
15 , "ordered-collections"
20 , "ordered-collections"
21+ , "parsing"
16 , "prelude"
22 , "prelude"
23+ , "profunctor-lenses"
17 , "record"
24 , "record"
18 , "run"
25 , "run"
19 , "strings"
26 , "strings"
src/Bun/Request.js+4
@@ -9,3 +9,7 @@ export function method(req) {
9export function url(req) {
9export function url(req) {
10 return req.url
10 return req.url
11}
11}
12+
13+export function headers(req) {
14+ return Object.fromEntries(req.headers.entries());
15+}
src/Bun/Request.purs+4
@@ -3,6 +3,7 @@ module Bun.Request
3 , method
3 , method
4 , url
4 , url
5 , json
5 , json
6+ , headers
6 ) where
7 ) where
7
8
8import Prelude
9import Prelude
@@ -11,6 +12,7 @@ import Control.Promise (Promise)
11import Control.Promise as Promise
12import Control.Promise as Promise
12import Data.Argonaut (Json)
13import Data.Argonaut (Json)
13import Effect.Aff (Aff)
14import Effect.Aff (Aff)
15+import Foreign.Object (Object)
14
16
15foreign import data Request :: Type
17foreign import data Request :: Type
16
18
@@ -22,3 +24,5 @@ json = jsonPromise >>> Promise.toAff
22foreign import method :: Request -> String
24foreign import method :: Request -> String
23
25
24foreign import url :: Request -> String
26foreign import url :: Request -> String
27+
28+foreign import headers :: Request -> Object String
src/Main.purs+10−7
@@ -7,7 +7,7 @@ import Data.Maybe (Maybe)
7import Effect (Effect)
7import Effect (Effect)
8import Effect.Aff (Aff)
8import Effect.Aff (Aff)
9import Effect.Console (log)
9import Effect.Console (log)
10−import PureStack.Route (type (/), GET, POST)
10+import PureStack.Route (type (/), GET, Headers(..), Middleware, POST)
11import PureStack.Route as Router
11import PureStack.Route as Router
12import PureStack.Server as Server
12import PureStack.Server as Server
13import Run (AFF, Run(..), runBaseAff)
13import Run (AFF, Run(..), runBaseAff)
@@ -16,11 +16,11 @@ import Type.Row (type (+))
16type Foo = { a :: String, b :: Maybe Int, c :: Array Number }
16type Foo = { a :: String, b :: Maybe Int, c :: Array Number }
17
17
18type API =
18type API =
19− ( foo :: "foo" / "bar" / Foo / GET { a :: Int, b :: Number, c :: Foo }
19+ ( foo :: "foo" / "bar" / Foo / GET Unit { a :: Int, b :: Number, c :: Foo }
20− , bar :: "foo" / "qux" / POST Unit { a :: Int }
20+ , bar :: "foo" / Middleware "auth" / "qux" / POST (Headers { foo :: String } Unit) { a :: Int, s :: String }
21 , deep ::
21 , deep ::
22 "deep" /
22 "deep" /
23− ( something :: "something" / GET { a :: String }
23+ ( something :: "something" / GET Unit { a :: String }
24 )
24 )
25 )
25 )
26
26
@@ -28,7 +28,10 @@ main :: Effect Unit
28main = do
28main = do
29 log "🍝"
29 log "🍝"
30 Bun.serve $ Server.run @API identity
30 Bun.serve $ Server.run @API identity
31+ { handlers:
31− { foo: \x -> pure { a: 1, b: 1.0, c: x }
32+ { foo: \x -> pure { a: 1, b: 1.0, c: x }
32− , bar: pure { a: 8 }
33+ , bar: \i (Headers x _) -> pure { a: 8, s: x.foo }
33− , deep: { something: pure { a: "something" } }
34+ , deep: { something: pure { a: "something" } }
35+ }
36+ , middlewares: { auth: \req -> pure 1 }
34 }
37 }
src/PureStack/Cookie.pursnew file+57
@@ -0,0 +1,57 @@
1+-- | This module allows parsing and generating cookie headers. You'll generally use
2+-- | the `Cookie.new` function to create a cookie from a name/value pair and the
3+-- | `Cookie.set*` functions to set attributes on a cookie.
4+-- |
5+-- | `Cookie.stringify` generates the string representation of a cookie, suitable for
6+-- | writing to an HTTP header.
7+-- |
8+-- | `Cookie.parse` parses the string representation of a cookie, returning an
9+-- | `Either ParseError Cookie`.
10+-- |
11+-- | ```purescript
12+-- | import PureStack.Cookie as Cookie
13+-- |
14+-- | > Cookie.stringify $ Cookie.setSecure $ Cookie.new "key" "value"
15+-- | key=value; Secure
16+-- |
17+-- | > Cookie.parse "key=value; Secure"
18+-- | (Right { name: "key", value: "value", secure: true, ... })
19+-- | ```
20+module PureStack.Cookie
21+ ( module PureStack.Cookie.Generator
22+ , module PureStack.Cookie.Parser
23+ , module PureStack.Cookie.Types
24+ ) where
25+
26+import PureStack.Cookie.Generator (stringify)
27+import PureStack.Cookie.Parser (parse, parseMany)
28+import PureStack.Cookie.Types
29+ ( Cookie
30+ , SameSite(..)
31+ , _domain
32+ , _expires
33+ , _httpOnly
34+ , _maxAge
35+ , _name
36+ , _path
37+ , _secure
38+ , _value
39+ , expire
40+ , fromFields
41+ , getDomain
42+ , getExpires
43+ , getHttpOnly
44+ , getMaxAge
45+ , getName
46+ , getPath
47+ , getSecure
48+ , getValue
49+ , new
50+ , setDomain
51+ , setExpires
52+ , setHttpOnly
53+ , setMaxAge
54+ , setPath
55+ , setSameSite
56+ , setSecure
57+ )
src/PureStack/Cookie/Formatter.pursnew file+65
@@ -0,0 +1,65 @@
1+-- | This module is responsible for formatting and parsing the `Expires`
2+-- | attribute of a `Cookie`.
3+module PureStack.Cookie.Formatter
4+ ( domainTag
5+ , expiresTag
6+ , formatDateTime
7+ , httpOnlyTag
8+ , maxAgeTag
9+ , pathTag
10+ , sameSiteTag
11+ , secureTag
12+ , unformatDateTime
13+ ) where
14+
15+import Data.DateTime (DateTime)
16+import Data.Either (Either)
17+import Data.Formatter.DateTime (Formatter, FormatterCommand(..))
18+import Data.Formatter.DateTime as Formatter
19+import Data.List as List
20+
21+domainTag :: String
22+domainTag = "Domain"
23+
24+expiresTag :: String
25+expiresTag = "Expires"
26+
27+httpOnlyTag :: String
28+httpOnlyTag = "HttpOnly"
29+
30+maxAgeTag :: String
31+maxAgeTag = "Max-Age"
32+
33+pathTag :: String
34+pathTag = "Path"
35+
36+secureTag :: String
37+secureTag = "Secure"
38+
39+sameSiteTag :: String
40+sameSiteTag = "SameSite"
41+
42+expiresFormatter :: Formatter
43+expiresFormatter =
44+ List.fromFoldable
45+ [ DayOfWeekNameShort
46+ , Placeholder ", "
47+ , DayOfMonthTwoDigits
48+ , Placeholder " "
49+ , MonthShort
50+ , Placeholder " "
51+ , YearFull
52+ , Placeholder " "
53+ , Hours24
54+ , Placeholder ":"
55+ , MinutesTwoDigits
56+ , Placeholder ":"
57+ , SecondsTwoDigits
58+ , Placeholder " GMT"
59+ ]
60+
61+formatDateTime :: DateTime -> String
62+formatDateTime = Formatter.format expiresFormatter
63+
64+unformatDateTime :: String -> Either String DateTime
65+unformatDateTime = Formatter.unformat expiresFormatter
src/PureStack/Cookie/Generator.pursnew file+62
@@ -0,0 +1,62 @@
1+-- | This module is responsible for generating the string representation
2+-- | of a `Cookie`.
3+module PureStack.Cookie.Generator
4+ ( stringify
5+ ) where
6+
7+import Prelude
8+import PureStack.Cookie.Formatter
9+ ( domainTag
10+ , expiresTag
11+ , formatDateTime
12+ , httpOnlyTag
13+ , maxAgeTag
14+ , pathTag
15+ , sameSiteTag
16+ , secureTag
17+ )
18+import PureStack.Cookie.Types
19+ ( Cookie
20+ , getDomain
21+ , getExpires
22+ , getHttpOnly
23+ , getMaxAge
24+ , getName
25+ , getPath
26+ , getSameSite
27+ , getSecure
28+ , getValue
29+ )
30+import Data.Array (catMaybes)
31+import Data.Foldable (intercalate)
32+import Data.Maybe (Maybe(..))
33+
34+-- | Return the `String` representation of a `Cookie`.
35+-- |
36+-- | ```purescript
37+-- | > Generator.stringify $ Cookie.setSecure $ Cookie.new "key" "value"
38+-- | key=value; Secure
39+-- | ```
40+stringify :: Cookie -> String
41+stringify cookie =
42+ intercalate "; "
43+ $ catMaybes
44+ [ attr (getName cookie) $ Just (getValue cookie)
45+ , attr domainTag $ getDomain cookie
46+ , attr pathTag $ getPath cookie
47+ , attr expiresTag $ formatDateTime <$> getExpires cookie
48+ , attr maxAgeTag $ show <$> getMaxAge cookie
49+ , attr sameSiteTag $ show <$> getSameSite cookie
50+ , flag secureTag $ getSecure cookie
51+ , flag httpOnlyTag $ getHttpOnly cookie
52+ ]
53+
54+attr :: String -> Maybe String -> Maybe String
55+attr name = case _ of
56+ Nothing -> Nothing
57+ Just value -> Just $ name <> "=" <> value
58+
59+flag :: String -> Boolean -> Maybe String
60+flag name = case _ of
61+ false -> Nothing
62+ true -> Just name
src/PureStack/Cookie/Parser.pursnew file+128
@@ -0,0 +1,128 @@
1+-- | This module is responsible for parsing a string into an
2+-- | `Either ParseError Cookie`.
3+module PureStack.Cookie.Parser
4+ ( parse
5+ , parseMany
6+ ) where
7+
8+import Prelude
9+
10+import Control.Alt ((<|>))
11+import Data.Array as Array
12+import Data.Either (Either(..))
13+import Data.Foldable (class Foldable, foldl)
14+import Data.Int as Int
15+import Data.List (List)
16+import Data.Maybe (Maybe(..))
17+import Data.String as String
18+import Parsing (ParseError, Parser, fail, runParser)
19+import Parsing.Combinators (many, sepBy)
20+import Parsing.String (eof, string)
21+import Parsing.String.Basic (noneOf)
22+import PureStack.Cookie.Formatter (domainTag, expiresTag, httpOnlyTag, maxAgeTag, pathTag, sameSiteTag, secureTag, unformatDateTime)
23+import PureStack.Cookie.Types (Cookie, SameSite(..))
24+import PureStack.Cookie.Types as Cookie
25+
26+type Attribute = Cookie -> Cookie
27+
28+dropSeperator :: Parser String Unit
29+dropSeperator = (string "; " $> unit) <|> (pure unit)
30+
31+asString :: forall f. Functor f => Foldable f => f Char -> String
32+asString = String.fromCodePointArray <<< Array.fromFoldable <<< map String.codePointFromChar
33+
34+stringWithout :: Array Char -> Parser String String
35+stringWithout = map asString <<< many <<< noneOf
36+
37+attributeValue :: Parser String String
38+attributeValue = stringWithout [ ';' ]
39+
40+whitespaceChars :: Array Char
41+whitespaceChars = [ ' ', '\n', '\r', '\t' ]
42+
43+parseDomain :: Parser String Attribute
44+parseDomain = do
45+ domain <- (string $ domainTag <> "=") *> attributeValue
46+ pure $ Cookie.setDomain domain
47+
48+parsePath :: Parser String Attribute
49+parsePath = do
50+ path <- (string $ pathTag <> "=") *> attributeValue
51+ pure $ Cookie.setPath path
52+
53+parseExpires :: Parser String Attribute
54+parseExpires = do
55+ expiresString <- (string $ expiresTag <> "=") *> attributeValue
56+ case unformatDateTime expiresString of
57+ Left e -> fail e
58+ Right expires -> pure $ Cookie.setExpires expires
59+
60+parseMaxAge :: Parser String Attribute
61+parseMaxAge = do
62+ maxAgeString <- (string $ maxAgeTag <> "=") *> attributeValue
63+ case Int.fromString maxAgeString of
64+ Nothing -> fail "invalid integer"
65+ Just maxAge -> pure $ Cookie.setMaxAge maxAge
66+
67+parseSecure :: Parser String Attribute
68+parseSecure = (string secureTag) $> Cookie.setSecure
69+
70+parseHttpOnly :: Parser String Attribute
71+parseHttpOnly = (string httpOnlyTag) $> Cookie.setHttpOnly
72+
73+parseSameSite :: Parser String Attribute
74+parseSameSite = do
75+ sameSiteString <- (string $ sameSiteTag <> "=") *> attributeValue
76+ case sameSiteString of
77+ "Strict" -> pure $ Cookie.setSameSite Strict
78+ "Lax" -> pure $ Cookie.setSameSite Lax
79+ "None" -> pure $ Cookie.setSameSite None
80+ val -> fail $ "unknown SiteSite value " <> val
81+
82+parseAttribute :: Parser String Attribute
83+parseAttribute =
84+ parseDomain
85+ <|> parsePath
86+ <|> parseExpires
87+ <|> parseMaxAge
88+ <|> parseSecure
89+ <|> parseHttpOnly
90+ <|> parseSameSite
91+
92+parseSimpleCookie :: Parser String Cookie
93+parseSimpleCookie = do
94+ name <- stringWithout ([ ';', ',', '=' ] <> whitespaceChars) <* string "="
95+ value <- stringWithout ([ ';', ',' ] <> whitespaceChars)
96+ pure $ Cookie.new name value
97+
98+parseCookie :: Parser String Cookie
99+parseCookie = do
100+ cookie <- parseSimpleCookie <* dropSeperator
101+ attributes <- sepBy parseAttribute (string "; ") <* eof
102+ pure $ foldl (#) cookie attributes
103+
104+parseCookies :: Parser String (List Cookie)
105+parseCookies = sepBy parseSimpleCookie (string "; ") <* eof
106+
107+-- | Parses a `String` into an `Either ParseError Cookie`. This
108+-- | function is primarily intended to parse the `Set-Cookie`
109+-- | header on the client.
110+-- |
111+-- | ```purescript
112+-- | > Parser.parse "key=value; Secure"
113+-- | (Right { name: "key", value: "value", secure: true, ... })
114+-- | ```
115+parse :: String -> Either ParseError Cookie
116+parse = flip runParser parseCookie
117+
118+-- | Parses a `String` into an `Either ParseError (List Cookie)`.
119+-- | HTTP requests can include multiple cookies in a single
120+-- | `Cookie` header consisting of only name/value pairs. This
121+-- | function can be used to parse this header.
122+-- |
123+-- | ```purescript
124+-- | > parseMany "key1=value1; key2=value2"
125+-- | (Right ({ name: "key1", value: "value1", ... } : { name: "key2", value: "value2", ... } : Nil))
126+-- | ```
127+parseMany :: String -> Either ParseError (List Cookie)
128+parseMany = flip runParser parseCookies
src/PureStack/Cookie/Types.pursnew file+189
@@ -0,0 +1,189 @@
1+-- | This module contains the `Cookie` type and functions for operating on data within it.
2+module PureStack.Cookie.Types
3+ ( Cookie
4+ , SameSite(..)
5+ , _domain
6+ , _expires
7+ , _httpOnly
8+ , _maxAge
9+ , _name
10+ , _path
11+ , _secure
12+ , _value
13+ , expire
14+ , fromFields
15+ , getDomain
16+ , getExpires
17+ , getHttpOnly
18+ , getMaxAge
19+ , getName
20+ , getPath
21+ , getSameSite
22+ , getSecure
23+ , getValue
24+ , new
25+ , setDomain
26+ , setExpires
27+ , setHttpOnly
28+ , setMaxAge
29+ , setPath
30+ , setSameSite
31+ , setSecure
32+ ) where
33+
34+import Prelude
35+import Data.DateTime (DateTime)
36+import Data.DateTime as DateTime
37+import Data.Either (Either(..))
38+import Data.Lens (Iso', Lens', iso)
39+import Data.Lens as Lens
40+import Data.Lens.Record (prop)
41+import Data.Maybe (Maybe(..))
42+import Data.Time.Duration (Days(..))
43+import Effect.Now (nowDateTime)
44+import Effect (Effect)
45+import Type.Prelude (Proxy(..))
46+
47+-- | Type representing a `Cookie`'s optional `SameSite` attribute.
48+data SameSite
49+ = Strict
50+ | Lax
51+ | None
52+
53+derive instance eqSameSite :: Eq SameSite
54+
55+derive instance ordSameSite :: Ord SameSite
56+
57+instance showSameSite :: Show SameSite where
58+ show :: SameSite -> String
59+ show Strict = "Strict"
60+ show Lax = "Lax"
61+ show None = "None"
62+
63+type CookieFields =
64+ { name :: String
65+ , value :: String
66+ , domain :: Maybe String
67+ , path :: Maybe String
68+ , expires :: Maybe DateTime
69+ , maxAge :: Maybe Int
70+ , sameSite :: Maybe SameSite
71+ , secure :: Boolean
72+ , httpOnly :: Boolean
73+ }
74+
75+-- | The `Cookie` type
76+newtype Cookie = Cookie CookieFields
77+
78+derive newtype instance eqCookie :: Eq Cookie
79+
80+derive newtype instance ordCookie :: Ord Cookie
81+
82+derive newtype instance showCookie :: Show Cookie
83+
84+-- | The constructor for `Cookie`
85+new :: String -> String -> Cookie
86+new name value =
87+ Cookie
88+ { name
89+ , value
90+ , domain: Nothing
91+ , path: Nothing
92+ , expires: Nothing
93+ , maxAge: Nothing
94+ , sameSite: Nothing
95+ , secure: false
96+ , httpOnly: false
97+ }
98+
99+fromFields :: CookieFields -> Cookie
100+fromFields = Cookie
101+
102+-- | Expire an existing `Cookie`. This sets the `Expires` attribute of
103+-- | the cookie to yesterday's date.
104+expire :: Cookie -> Effect (Either String Cookie)
105+expire cookie = do
106+ now <- nowDateTime
107+ let maybeDate = DateTime.adjust (Days $ -1.0) now
108+
109+ case maybeDate of
110+ Nothing -> pure $ Left "Invalid date"
111+ Just yesterday -> pure $ Right $ setExpires yesterday cookie
112+
113+getDomain :: Cookie -> Maybe String
114+getDomain = Lens.view _domain
115+
116+getExpires :: Cookie -> Maybe DateTime
117+getExpires = Lens.view _expires
118+
119+getHttpOnly :: Cookie -> Boolean
120+getHttpOnly = Lens.view _httpOnly
121+
122+getMaxAge :: Cookie -> Maybe Int
123+getMaxAge = Lens.view _maxAge
124+
125+getName :: Cookie -> String
126+getName = Lens.view _name
127+
128+getPath :: Cookie -> Maybe String
129+getPath = Lens.view _path
130+
131+getSameSite :: Cookie -> Maybe SameSite
132+getSameSite = Lens.view _sameSite
133+
134+getSecure :: Cookie -> Boolean
135+getSecure = Lens.view _secure
136+
137+getValue :: Cookie -> String
138+getValue = Lens.view _value
139+
140+setDomain :: String -> Cookie -> Cookie
141+setDomain = Lens.setJust _domain
142+
143+setExpires :: DateTime -> Cookie -> Cookie
144+setExpires = Lens.setJust _expires
145+
146+setHttpOnly :: Cookie -> Cookie
147+setHttpOnly = Lens.set _httpOnly true
148+
149+setMaxAge :: Int -> Cookie -> Cookie
150+setMaxAge = Lens.setJust _maxAge
151+
152+setPath :: String -> Cookie -> Cookie
153+setPath = Lens.setJust _path
154+
155+setSameSite :: SameSite -> Cookie -> Cookie
156+setSameSite = Lens.setJust _sameSite
157+
158+setSecure :: Cookie -> Cookie
159+setSecure = Lens.set _secure true
160+
161+_Cookie :: Iso' Cookie CookieFields
162+_Cookie = iso (\(Cookie fields) -> fields) Cookie
163+
164+_domain :: Lens' Cookie (Maybe String)
165+_domain = _Cookie <<< prop (Proxy :: Proxy "domain")
166+
167+_expires :: Lens' Cookie (Maybe DateTime)
168+_expires = _Cookie <<< prop (Proxy :: Proxy "expires")
169+
170+_httpOnly :: Lens' Cookie Boolean
171+_httpOnly = _Cookie <<< prop (Proxy :: Proxy "httpOnly")
172+
173+_maxAge :: Lens' Cookie (Maybe Int)
174+_maxAge = _Cookie <<< prop (Proxy :: Proxy "maxAge")
175+
176+_name :: Lens' Cookie String
177+_name = _Cookie <<< prop (Proxy :: Proxy "name")
178+
179+_path :: Lens' Cookie (Maybe String)
180+_path = _Cookie <<< prop (Proxy :: Proxy "path")
181+
182+_sameSite :: Lens' Cookie (Maybe SameSite)
183+_sameSite = _Cookie <<< prop (Proxy :: Proxy "sameSite")
184+
185+_secure :: Lens' Cookie Boolean
186+_secure = _Cookie <<< prop (Proxy :: Proxy "secure")
187+
188+_value :: Lens' Cookie String
189+_value = _Cookie <<< prop (Proxy :: Proxy "value")
src/PureStack/Route.purs+31−11
@@ -1,27 +1,45 @@
1module PureStack.Route
1module PureStack.Route
2 ( type (/)
2 ( type (/)
3 , Slash
3 , Slash
4+ , HttpMethod
5+ , class MethodName
6+ , methodName
4 , GET
7 , GET
5 , POST
8 , POST
6 , PUT
9 , PUT
7 , DELETE
10 , DELETE
8 , PATCH
11 , PATCH
12+ , Headers(..)
13+ , Middleware
9 ) where
14 ) where
10
15
11−data GET :: Type -> Type
16+data HttpMethod
12−data GET resp
13
17
14−data POST :: Type -> Type -> Type
18+-- | The `req` can only ever be `Unit`
15−data POST req resp
19+foreign import data GET :: Type -> Type -> HttpMethod
20+foreign import data POST :: Type -> Type -> HttpMethod
21+foreign import data PUT :: Type -> Type -> HttpMethod
22+foreign import data DELETE :: Type -> Type -> HttpMethod
23+foreign import data PATCH :: Type -> Type -> HttpMethod
16
24
17−data PUT :: Type -> Type -> Type
25+class MethodName :: HttpMethod -> Constraint
18−data PUT req resp
26+class MethodName method where
27+ methodName :: String
19
28
20−data DELETE :: Type -> Type -> Type
29+instance MethodName (GET req resp) where
21−data DELETE req resp
30+ methodName = "GET"
22
31
23−data PATCH :: Type -> Type -> Type
32+instance MethodName (POST req resp) where
33+ methodName = "POST"
34+
35+instance MethodName (PUT req resp) where
36+ methodName = "PUT"
37+
38+instance MethodName (DELETE req resp) where
39+ methodName = "DELETE"
40+
24−data PATCH req resp
41+instance MethodName (PATCH req resp) where
42+ methodName = "PATCH"
25
43
26data Slash :: forall k1 k2. k1 -> k2 -> Type
44data Slash :: forall k1 k2. k1 -> k2 -> Type
27data Slash x y
45data Slash x y
@@ -32,4 +50,6 @@ data Slash x y
32-- | Other types are captured path pieces.
50-- | Other types are captured path pieces.
33infixr 1 type Slash as /
51infixr 1 type Slash as /
34
52
35−data Headers headers r = Headers (Record headers) r
53+data Headers headers r = Headers headers r
54+
55+data Middleware tag
src/PureStack/Server.purs+145−154
@@ -20,12 +20,17 @@ module PureStack.Server
20 , serveQuery
20 , serveQuery
21 , class ParsePathPiece
21 , class ParsePathPiece
22 , parsePathPiece
22 , parsePathPiece
23+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
23 ) where
27 ) where
24
28
25import Prelude
29import Prelude
26import PureStack.Route
30import PureStack.Route
27
31
28import Bun.Request (Request)
32import Bun.Request (Request)
33+import Bun.Request as Bun
29import Bun.Request as Request
34import Bun.Request as Request
30import Bun.Response as Bun.Response
35import Bun.Response as Bun.Response
31import Control.Alternative (class Plus, empty)
36import Control.Alternative (class Plus, empty)
@@ -49,12 +54,19 @@ import Foreign.Object as Object
49import Prim.Row as Row
54import Prim.Row as Row
50import Prim.RowList (class RowToList, RowList)
55import Prim.RowList (class RowToList, RowList)
51import Prim.RowList as RowList
56import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
52import Record as Record
59import Record as Record
53import Record.Builder (Builder)
60import Record.Builder (Builder)
54import Record.Builder as Builder
61import Record.Builder as Builder
55import Type.Proxy (Proxy(..))
62import Type.Proxy (Proxy(..))
56
63
64+type Route =
65+ { path :: Array String
66+ , verb :: String
57−type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
69+ }
58
70
59routeFromRequest :: Request -> Route
71routeFromRequest :: Request -> Route
60routeFromRequest req =
72routeFromRequest req =
@@ -71,180 +83,81 @@ routeFromRequest req =
71 , query: case url of
83 , query: case url of
72 Nothing -> Map.empty
84 Nothing -> Map.empty
73 Just u -> URL.query u
85 Just u -> URL.query u
86+ , originalRequest: req
74 }
87 }
75
88
76type Server a = ExceptT Response Aff a
89type Server a = ExceptT Response Aff a
77
90
78newtype Nt m = Nt (forall x. m x -> Server x)
91newtype Nt m = Nt (forall x. m x -> Server x)
79
92
80−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
93+class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
81−class ServeRoute route handler m | route -> handler, handler -> m where
94+class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
82− serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
95+ serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
83
96
84−instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
97+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
85 serveRoute route@{ path } = do
98 serveRoute route@{ path } = do
86 { head: h, tail } <- Array.uncons path
99 { head: h, tail } <- Array.uncons path
87 assert $ h == (reflectSymbol @path Proxy)
100 assert $ h == (reflectSymbol @path Proxy)
88 serveRoute @rest route { path = tail }
101 serveRoute @rest route { path = tail }
89
102
90else instance
103else instance
91− ( ServeRoute rest handler m
104+ ( ServeRoute rest handler middlewares m
92 , ServeQuery row list
105 , ServeQuery row list
93 , RowToList row list
106 , RowToList row list
94 ) =>
107 ) =>
95− ServeRoute (Record row / rest) (Record row -> handler) m where
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
96 serveRoute route@{ query } = do
109 serveRoute route@{ query } = do
97 builder <- serveQuery @row @list query
110 builder <- serveQuery @row @list query
98 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
111 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
99
112
113+else instance
114+ ( ServeRoute rest handler middlewares m
115+ , IsSymbol field
116+ , Row.Cons field (Bun.Request -> m x) tail middlewares
117+ ) =>
118+ ServeRoute (Middleware field / rest) (x -> handler) middlewares m where
119+ serveRoute route@{ originalRequest } = do
120+ serveRoute @rest route <#>
121+ ( \f nt@(Nt ntf) handler middlewares req -> do
122+ x <- ntf $ Record.get (Proxy @field) middlewares originalRequest
123+ f nt (handler x) middlewares req
124+ )
125+
100−else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
126+else instance (ServeRoute rest handler middlewares m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) middlewares m where
101 serveRoute route@{ path } = do
127 serveRoute route@{ path } = do
102 { head: h, tail } <- Array.uncons path
128 { head: h, tail } <- Array.uncons path
103 t <- parsePathPiece @t h
129 t <- parsePathPiece @t h
104− serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
105−
106−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
107− serveRoute { path, verb } = do
108− assert $ verb == "GET"
109− assert $ path == []
110− pure $ \(Nt nt) handler _req -> do
111− resp <- nt handler
112− pure $ toResponse resp
113−
114−else instance ServeRoute (POST Unit Unit) (m Unit) m where
115− serveRoute { path, verb } = do
116− assert $ verb == "POST"
117− assert $ path == []
118− pure $ \(Nt nt) handler _req -> do
119− nt handler
120− pure $ ok
121−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
122− serveRoute { path, verb } = do
123− assert $ verb == "POST"
124− assert $ path == []
125− pure $ \(Nt nt) handler _req -> do
126− resp <- nt handler
127− pure $ toResponse resp
128−else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
129− serveRoute { path, verb } = do
130− assert $ verb == "POST"
131− assert $ path == []
132− pure $ \(Nt nt) handler req -> do
133− liftAff (fromRequest req) >>= case _ of
134− Nothing -> pure $ badRequest
135− Just r -> do
136− nt $ handler r
137− pure $ ok
138−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
139− serveRoute { path, verb } = do
140− assert $ verb == "POST"
141− assert $ path == []
142− pure $ \(Nt nt) handler req -> do
143− liftAff (fromRequest req) >>= case _ of
144− Nothing -> pure $ badRequest
145− Just r -> do
146− resp <- nt $ handler r
147− pure $ toResponse resp
148
131
149−else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
150 serveRoute { path, verb } = do
133 serveRoute { path, verb } = do
151− assert $ verb == "DELETE"
134+ assert $ verb == methodName @(meth Unit Unit)
152 assert $ path == []
135 assert $ path == []
153− pure $ \(Nt nt) handler _req -> do
136+ pure $ \(Nt nt) handler _middlewares _req -> do
154 nt handler
137 nt handler
155 pure $ ok
138 pure $ ok
156−else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
139+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where
157 serveRoute { path, verb } = do
140 serveRoute { path, verb } = do
158− assert $ verb == "DELETE"
141+ assert $ verb == methodName @(meth Unit resp)
159 assert $ path == []
142 assert $ path == []
160− pure $ \(Nt nt) handler _req -> do
143+ pure $ \(Nt nt) handler _middlewares _req -> do
161 resp <- nt handler
144 resp <- nt handler
162 pure $ toResponse resp
145 pure $ toResponse resp
163−else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
146+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where
164 serveRoute { path, verb } = do
147 serveRoute { path, verb } = do
165− assert $ verb == "DELETE"
148+ assert $ verb == methodName @(meth resp Unit)
166 assert $ path == []
149 assert $ path == []
167− pure $ \(Nt nt) handler req -> do
150+ pure $ \(Nt nt) handler _middlewares req -> do
168 liftAff (fromRequest req) >>= case _ of
151 liftAff (fromRequest req) >>= case _ of
169 Nothing -> pure $ badRequest
152 Nothing -> pure $ badRequest
170 Just r -> do
153 Just r -> do
171 nt $ handler r
154 nt $ handler r
172 pure $ ok
155 pure $ ok
173−else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
156+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) middlewares m where
174 serveRoute { path, verb } = do
157 serveRoute { path, verb } = do
175− assert $ verb == "DELETE"
158+ assert $ verb == methodName @(meth req resp)
176 assert $ path == []
159 assert $ path == []
177− pure $ \(Nt nt) handler req -> do
160+ pure $ \(Nt nt) handler _middlewares req -> do
178− liftAff (fromRequest req) >>= case _ of
179− Nothing -> pure $ badRequest
180− Just r -> do
181− resp <- nt $ handler r
182− pure $ toResponse resp
183−
184−else instance ServeRoute (PUT Unit Unit) (m Unit) m where
185− serveRoute { path, verb } = do
186− assert $ verb == "PUT"
187− assert $ path == []
188− pure $ \(Nt nt) handler _req -> do
189− nt handler
190− pure $ ok
191−else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where
192− serveRoute { path, verb } = do
193− assert $ verb == "PUT"
194− assert $ path == []
195− pure $ \(Nt nt) handler _req -> do
196− resp <- nt handler
197− pure $ toResponse resp
198−else instance (FromRequest req) => ServeRoute (PUT resp Unit) (req -> m Unit) m where
199− serveRoute { path, verb } = do
200− assert $ verb == "PUT"
201− assert $ path == []
202− pure $ \(Nt nt) handler req -> do
203− liftAff (fromRequest req) >>= case _ of
204− Nothing -> pure $ badRequest
205− Just r -> do
206− nt $ handler r
207− pure $ ok
208−else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT req resp) (req -> m resp) m where
209− serveRoute { path, verb } = do
210− assert $ verb == "PUT"
211− assert $ path == []
212− pure $ \(Nt nt) handler req -> do
213− liftAff (fromRequest req) >>= case _ of
214− Nothing -> pure $ badRequest
215− Just r -> do
216− resp <- nt $ handler r
217− pure $ toResponse resp
218−
219−else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
220− serveRoute { path, verb } = do
221− assert $ verb == "PATCH"
222− assert $ path == []
223− pure $ \(Nt nt) handler _req -> do
224− nt handler
225− pure $ ok
226−else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
227− serveRoute { path, verb } = do
228− assert $ verb == "PATCH"
229− assert $ path == []
230− pure $ \(Nt nt) handler _req -> do
231− resp <- nt handler
232− pure $ toResponse resp
233−else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where
234− serveRoute { path, verb } = do
235− assert $ verb == "PATCH"
236− assert $ path == []
237− pure $ \(Nt nt) handler req -> do
238− liftAff (fromRequest req) >>= case _ of
239− Nothing -> pure $ badRequest
240− Just r -> do
241− nt $ handler r
242− pure $ ok
243−else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where
244− serveRoute { path, verb } = do
245− assert $ verb == "PATCH"
246− assert $ path == []
247− pure $ \(Nt nt) handler req -> do
248 liftAff (fromRequest req) >>= case _ of
161 liftAff (fromRequest req) >>= case _ of
249 Nothing -> pure $ badRequest
162 Nothing -> pure $ badRequest
250 Just r -> do
163 Just r -> do
@@ -252,12 +165,12 @@ else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp)
252 pure $ toResponse resp
165 pure $ toResponse resp
253
166
254else instance
167else instance
255− ( ServeAPI routes list handlers m
168+ ( ServeAPI routes list handlers middlewares m
256 , RowToList routes list
169 , RowToList routes list
257 ) =>
170 ) =>
258− ServeRoute routes (Record handlers) m where
171+ ServeRoute routes (Record handlers) middlewares m where
259− serveRoute route = pure $ \nt handlers req ->
172+ serveRoute route = pure $ \nt handlers middlewares req ->
260− serveAPI @routes @list nt handlers route req
173+ serveAPI @routes @list nt handlers middlewares route req
261
174
262class ServeQuery :: Row Type -> RowList Type -> Constraint
175class ServeQuery :: Row Type -> RowList Type -> Constraint
263class ServeQuery row list | list -> row where
176class ServeQuery row list | list -> row where
@@ -342,6 +255,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
342instance FromRequest Request where
255instance FromRequest Request where
343 fromRequest req = pure $ Just req
256 fromRequest req = pure $ Just req
344
257
258+instance FromRequest Unit where
259+ fromRequest _ = pure $ Just unit
260+
261+instance
262+ ( FromRequest req
263+ , FromHeader header
264+ ) =>
265+ FromRequest (Headers (Object header) req) where
266+ fromRequest req = do
267+ r <- fromRequest req
268+ pure $ do
269+ headers <- traverse fromHeader (Request.headers req)
270+ r' <- r
271+ pure $ Headers headers r'
272+
273+instance
274+ ( RowToList headers headersList
275+ , FromRequest req
276+ , FromHeaders headers headersList
277+ ) =>
278+ FromRequest (Headers (Record headers) req) where
279+ fromRequest req = do
280+ r <- fromRequest req
281+ pure $ do
282+ headers <- fromHeaders @headers @headersList (Request.headers req)
283+ r' <- r
284+ pure $ Headers (Builder.buildFromScratch headers) r'
285+
286+class FromHeader t where
287+ fromHeader :: String -> Maybe t
288+
289+instance FromHeader Cookie where
290+ fromHeader = Cookie.parse >>> case _ of
291+ Left _ -> Nothing
292+ Right x -> Just x
293+
294+instance FromHeader String where
295+ fromHeader = Just
296+
297+instance FromHeader Int where
298+ fromHeader = Int.fromString
299+
300+class FromHeaders :: Row Type -> RowList Type -> Constraint
301+class FromHeaders row list | list -> row where
302+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
303+
304+instance FromHeaders () RowList.Nil where
305+ fromHeaders _ = Just $ identity
306+
307+instance
308+ ( FromHeader t
309+ , IsSymbol field
310+ , FromHeaders tail rest
311+ , Row.Cons field (Maybe t) tail row
312+ , Row.Lacks field tail
313+ ) =>
314+ FromHeaders row (RowList.Cons field (Maybe t) rest) where
315+ fromHeaders headers = do
316+ r <- fromHeaders @tail @rest headers
317+ case Object.lookup (reflectSymbol @field Proxy) headers of
318+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
319+ Just t -> do
320+ v <- fromHeader t
321+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
322+
323+else instance
324+ ( FromHeader t
325+ , IsSymbol field
326+ , FromHeaders tail rest
327+ , Row.Cons field t tail row
328+ , Row.Lacks field tail
329+ ) =>
330+ FromHeaders row (RowList.Cons field t rest) where
331+ fromHeaders headers = do
332+ t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
333+ r <- fromHeaders @tail @rest headers
334+ pure $ Builder.insert (Proxy @field) t <<< r
335+
345class ParsePathPiece t where
336class ParsePathPiece t where
346 parsePathPiece :: String -> Maybe t
337 parsePathPiece :: String -> Maybe t
347
338
@@ -366,26 +357,26 @@ assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
366assert true = pure unit
357assert true = pure unit
367assert false = empty
358assert false = empty
368
359
369−class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
360+class ServeAPI :: Row Type -> RowList Type -> Row Type -> Row Type -> (Type -> Type) -> Constraint
370−class ServeAPI row list handlers m | row -> handlers, handlers -> m where
361+class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
371− serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
362+ serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
372
363
373−instance ServeAPI row RowList.Nil () m where
364+instance ServeAPI row RowList.Nil () middlewares m where
374− serveAPI _ _ _ _ = pure notFound
365+ serveAPI _ _ _ _ _ = pure notFound
375
366
376instance
367instance
377− ( ServeRoute t handler m
368+ ( ServeRoute t handler middlewares m
378 , Row.Cons field t tail row
369 , Row.Cons field t tail row
379− , ServeAPI row rest restHandlers m
370+ , ServeAPI row rest restHandlers middlewares m
380 , IsSymbol field
371 , IsSymbol field
381 , Row.Cons field handler restHandlers handlers
372 , Row.Cons field handler restHandlers handlers
382 , Row.Lacks field restHandlers
373 , Row.Lacks field restHandlers
383 ) =>
374 ) =>
384− ServeAPI row (RowList.Cons field t rest) handlers m where
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
385− serveAPI nt handlers route req =
376+ serveAPI nt handlers middlewares route req =
386 case serveRoute @t route of
377 case serveRoute @t route of
387− Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
378+ Nothing -> serveAPI @row @rest @restHandlers @middlewares nt (Record.delete (Proxy @field) handlers) middlewares route req
388− Just f -> f nt (Record.get (Proxy @field) handlers) req
379+ Just f -> f nt (Record.get (Proxy @field) handlers) middlewares req
389
380
390notFound :: Response
381notFound :: Response
391notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
382notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
@@ -402,16 +393,16 @@ ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers:
402-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
393-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
403-- | instead you can just pass `identity` as the first argument.
394-- | instead you can just pass `identity` as the first argument.
404run
395run
405− :: forall @row list handlers m
396+ :: forall @row list handlers m middlewares
406 . RowToList row list
397 . RowToList row list
407− => ServeAPI row list handlers m
398+ => ServeAPI row list handlers middlewares m
408 => (forall x. m x -> Server x)
399 => (forall x. m x -> Server x)
409− -> Record handlers
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
410 -> Request
401 -> Request
411 -> Aff Bun.Response.Response
402 -> Aff Bun.Response.Response
412−run nt handlers req = do
403+run nt { handlers, middlewares } req = do
413 Response { body, headers, status, statusText } <-
404 Response { body, headers, status, statusText } <-
414− map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
405+ map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers middlewares (routeFromRequest req) req
415 let opts = { headers, status, statusText }
406 let opts = { headers, status, statusText }
416 pure $ case body of
407 pure $ case body of
417 EmptyResponseBody -> Bun.Response.string "" opts
408 EmptyResponseBody -> Bun.Response.string "" opts