git.iko.soy/purestack-dev/purescript-purestack-server
on master help sign in
Request headers
e4cfd92iko
spago.dhall+7
compare with master
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+9−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(..), 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" / "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,9 @@ 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: \(Headers x _) -> pure { a: 8, s: x.foo }
33− , deep: { something: pure { a: "something" } }
34+ , deep: { something: pure { a: "something" } }
35+ }
34 }
36 }
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+28−11
@@ -1,27 +1,44 @@
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(..)
9 ) where
13 ) where
10
14
11−data GET :: Type -> Type
15+data HttpMethod
12−data GET resp
13
16
14−data POST :: Type -> Type -> Type
17+-- | The `req` can only ever be `Unit`
15−data POST req resp
18+foreign import data GET :: Type -> Type -> HttpMethod
19+foreign import data POST :: Type -> Type -> HttpMethod
20+foreign import data PUT :: Type -> Type -> HttpMethod
21+foreign import data DELETE :: Type -> Type -> HttpMethod
22+foreign import data PATCH :: Type -> Type -> HttpMethod
16
23
17−data PUT :: Type -> Type -> Type
24+class MethodName :: HttpMethod -> Constraint
18−data PUT req resp
25+class MethodName method where
26+ methodName :: String
19
27
20−data DELETE :: Type -> Type -> Type
28+instance MethodName (GET req resp) where
21−data DELETE req resp
29+ methodName = "GET"
22
30
23−data PATCH :: Type -> Type -> Type
31+instance MethodName (POST req resp) where
32+ methodName = "POST"
33+
34+instance MethodName (PUT req resp) where
35+ methodName = "PUT"
36+
37+instance MethodName (DELETE req resp) where
38+ methodName = "DELETE"
39+
24−data PATCH req resp
40+instance MethodName (PATCH req resp) where
41+ methodName = "PATCH"
25
42
26data Slash :: forall k1 k2. k1 -> k2 -> Type
43data Slash :: forall k1 k2. k1 -> k2 -> Type
27data Slash x y
44data Slash x y
@@ -32,4 +49,4 @@ data Slash x y
32-- | Other types are captured path pieces.
49-- | Other types are captured path pieces.
33infixr 1 type Slash as /
50infixr 1 type Slash as /
34
51
35−data Headers headers r = Headers (Record headers) r
52+data Headers headers r = Headers headers r
src/PureStack/Server.purs+94−123
@@ -20,6 +20,10 @@ 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
@@ -49,6 +53,8 @@ import Foreign.Object as Object
49import Prim.Row as Row
53import Prim.Row as Row
50import Prim.RowList (class RowToList, RowList)
54import Prim.RowList (class RowToList, RowList)
51import Prim.RowList as RowList
55import Prim.RowList as RowList
56+import PureStack.Cookie (Cookie)
57+import PureStack.Cookie as Cookie
52import Record as Record
58import Record as Record
53import Record.Builder (Builder)
59import Record.Builder (Builder)
54import Record.Builder as Builder
60import Record.Builder as Builder
@@ -103,31 +109,23 @@ else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / r
103 t <- parsePathPiece @t h
109 t <- parsePathPiece @t h
104 serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
110 serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
105
111
106−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
112+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) m where
107 serveRoute { path, verb } = do
113 serveRoute { path, verb } = do
108− assert $ verb == "GET"
114+ assert $ verb == methodName @(meth Unit Unit)
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 == []
115 assert $ path == []
118 pure $ \(Nt nt) handler _req -> do
116 pure $ \(Nt nt) handler _req -> do
119 nt handler
117 nt handler
120 pure $ ok
118 pure $ ok
121−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
119+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) m where
122 serveRoute { path, verb } = do
120 serveRoute { path, verb } = do
123− assert $ verb == "POST"
121+ assert $ verb == methodName @(meth Unit resp)
124 assert $ path == []
122 assert $ path == []
125 pure $ \(Nt nt) handler _req -> do
123 pure $ \(Nt nt) handler _req -> do
126 resp <- nt handler
124 resp <- nt handler
127 pure $ toResponse resp
125 pure $ toResponse resp
128−else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
126+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) m where
129 serveRoute { path, verb } = do
127 serveRoute { path, verb } = do
130− assert $ verb == "POST"
128+ assert $ verb == methodName @(meth resp Unit)
131 assert $ path == []
129 assert $ path == []
132 pure $ \(Nt nt) handler req -> do
130 pure $ \(Nt nt) handler req -> do
133 liftAff (fromRequest req) >>= case _ of
131 liftAff (fromRequest req) >>= case _ of
@@ -135,114 +133,9 @@ else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m
135 Just r -> do
133 Just r -> do
136 nt $ handler r
134 nt $ handler r
137 pure $ ok
135 pure $ ok
138−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
136+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) m where
139 serveRoute { path, verb } = do
137 serveRoute { path, verb } = do
140− assert $ verb == "POST"
138+ assert $ verb == methodName @(meth req resp)
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−
149−else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
150− serveRoute { path, verb } = do
151− assert $ verb == "DELETE"
152− assert $ path == []
153− pure $ \(Nt nt) handler _req -> do
154− nt handler
155− pure $ ok
156−else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
157− serveRoute { path, verb } = do
158− assert $ verb == "DELETE"
159− assert $ path == []
160− pure $ \(Nt nt) handler _req -> do
161− resp <- nt handler
162− pure $ toResponse resp
163−else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
164− serveRoute { path, verb } = do
165− assert $ verb == "DELETE"
166− assert $ path == []
167− pure $ \(Nt nt) handler req -> do
168− liftAff (fromRequest req) >>= case _ of
169− Nothing -> pure $ badRequest
170− Just r -> do
171− nt $ handler r
172− pure $ ok
173−else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
174− serveRoute { path, verb } = do
175− assert $ verb == "DELETE"
176− assert $ path == []
177− pure $ \(Nt nt) handler 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 == []
139 assert $ path == []
247 pure $ \(Nt nt) handler req -> do
140 pure $ \(Nt nt) handler req -> do
248 liftAff (fromRequest req) >>= case _ of
141 liftAff (fromRequest req) >>= case _ of
@@ -342,6 +235,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
342instance FromRequest Request where
235instance FromRequest Request where
343 fromRequest req = pure $ Just req
236 fromRequest req = pure $ Just req
344
237
238+instance FromRequest Unit where
239+ fromRequest _ = pure $ Just unit
240+
241+instance
242+ ( FromRequest req
243+ , FromHeader header
244+ ) =>
245+ FromRequest (Headers (Object header) req) where
246+ fromRequest req = do
247+ r <- fromRequest req
248+ pure $ do
249+ headers <- traverse fromHeader (Request.headers req)
250+ r' <- r
251+ pure $ Headers headers r'
252+
253+instance
254+ ( RowToList headers headersList
255+ , FromRequest req
256+ , FromHeaders headers headersList
257+ ) =>
258+ FromRequest (Headers (Record headers) req) where
259+ fromRequest req = do
260+ r <- fromRequest req
261+ pure $ do
262+ headers <- fromHeaders @headers @headersList (Request.headers req)
263+ r' <- r
264+ pure $ Headers (Builder.buildFromScratch headers) r'
265+
266+class FromHeader t where
267+ fromHeader :: String -> Maybe t
268+
269+instance FromHeader Cookie where
270+ fromHeader = Cookie.parse >>> case _ of
271+ Left _ -> Nothing
272+ Right x -> Just x
273+
274+instance FromHeader String where
275+ fromHeader = Just
276+
277+instance FromHeader Int where
278+ fromHeader = Int.fromString
279+
280+class FromHeaders :: Row Type -> RowList Type -> Constraint
281+class FromHeaders row list | list -> row where
282+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
283+
284+instance FromHeaders () RowList.Nil where
285+ fromHeaders _ = Just $ identity
286+
287+instance
288+ ( FromHeader t
289+ , IsSymbol field
290+ , FromHeaders tail rest
291+ , Row.Cons field (Maybe t) tail row
292+ , Row.Lacks field tail
293+ ) =>
294+ FromHeaders row (RowList.Cons field (Maybe t) rest) where
295+ fromHeaders headers = do
296+ r <- fromHeaders @tail @rest headers
297+ case Object.lookup (reflectSymbol @field Proxy) headers of
298+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
299+ Just t -> do
300+ v <- fromHeader t
301+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
302+
303+else instance
304+ ( FromHeader t
305+ , IsSymbol field
306+ , FromHeaders tail rest
307+ , Row.Cons field t tail row
308+ , Row.Lacks field tail
309+ ) =>
310+ FromHeaders row (RowList.Cons field t rest) where
311+ fromHeaders headers = do
312+ t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
313+ r <- fromHeaders @tail @rest headers
314+ pure $ Builder.insert (Proxy @field) t <<< r
315+
345class ParsePathPiece t where
316class ParsePathPiece t where
346 parsePathPiece :: String -> Maybe t
317 parsePathPiece :: String -> Maybe t
347
318
@@ -406,10 +377,10 @@ run
406 . RowToList row list
377 . RowToList row list
407 => ServeAPI row list handlers m
378 => ServeAPI row list handlers m
408 => (forall x. m x -> Server x)
379 => (forall x. m x -> Server x)
409− -> Record handlers
380+ -> { handlers :: Record handlers }
410 -> Request
381 -> Request
411 -> Aff Bun.Response.Response
382 -> Aff Bun.Response.Response
412−run nt handlers req = do
383+run nt { handlers } req = do
413 Response { body, headers, status, statusText } <-
384 Response { body, headers, status, statusText } <-
414 map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
385 map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
415 let opts = { headers, status, statusText }
386 let opts = { headers, status, statusText }