@@ -1,5 +1,7 @@
1module PureStack.Server
1module PureStack.Server
3 , class ToResponse
5 , class ToResponse
4 , toResponse
6 , toResponse
5 , class FromRequest
7 , class FromRequest
@@ -18,20 +20,24 @@ module PureStack.Server
18 , serveQuery
20 , serveQuery
19 , class ParsePathPiece
21 , class ParsePathPiece
20 , parsePathPiece
22 , parsePathPiece
23import Prelude
29import Prelude
24import PureStack.Route
30import PureStack.Route
26import Bun.Request (Request)
32import Bun.Request (Request)
33+import Bun.Request as Bun
27import Bun.Request as Request
34import Bun.Request as Request
28−import Bun.Response (Response)
35+import Bun.Response as Bun.Response
29−import Bun.Response as Response
30import Control.Alternative (class Plus, empty)
36import Control.Alternative (class Plus, empty)
31import Control.Monad.Except (ExceptT, runExceptT)
37import Control.Monad.Except (ExceptT, runExceptT)
32−import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
38+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
33import Data.Array as Array
39import Data.Array as Array
34−import Data.Either (Either(..))
40+import Data.Either (Either(..), either)
35import Data.Int as Int
41import Data.Int as Int
36import Data.Map (Map)
42import Data.Map (Map)
37import Data.Map as Map
43import Data.Map as Map
@@ -43,15 +49,24 @@ import Data.Traversable (traverse)
43import Data.URL as URL
49import Data.URL as URL
44import Effect.Aff (Aff)
50import Effect.Aff (Aff)
45import Effect.Aff.Class (liftAff)
51import Effect.Aff.Class (liftAff)
52+import Foreign.Object (Object)
53+import Foreign.Object as Object
46import Prim.Row as Row
54import Prim.Row as Row
47import Prim.RowList (class RowToList, RowList)
55import Prim.RowList (class RowToList, RowList)
48import Prim.RowList as RowList
56import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
49import Record as Record
59import Record as Record
50import Record.Builder (Builder)
60import Record.Builder (Builder)
51import Record.Builder as Builder
61import Record.Builder as Builder
52import Type.Proxy (Proxy(..))
62import Type.Proxy (Proxy(..))
65+ { path :: Array String
54−type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
56routeFromRequest :: Request -> Route
71routeFromRequest :: Request -> Route
57routeFromRequest req =
72routeFromRequest req =
@@ -68,185 +83,94 @@ routeFromRequest req =
68 , query: case url of
83 , query: case url of
69 Nothing -> Map.empty
84 Nothing -> Map.empty
70 Just u -> URL.query u
85 Just u -> URL.query u
86+ , originalRequest: req
73type Server a = ExceptT Response Aff a
89type Server a = ExceptT Response Aff a
75newtype Nt m = Nt (forall x. m x -> Server x)
91newtype Nt m = Nt (forall x. m x -> Server x)
77−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
93+class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
78−class ServeRoute route handler m | route -> handler, handler -> m where
94+class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
79− serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
95+ serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
81−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
82 serveRoute route@{ path } = do
98 serveRoute route@{ path } = do
83 { head: h, tail } <- Array.uncons path
99 { head: h, tail } <- Array.uncons path
84 assert $ h == (reflectSymbol @path Proxy)
100 assert $ h == (reflectSymbol @path Proxy)
85 serveRoute @rest route { path = tail }
101 serveRoute @rest route { path = tail }
87else instance
103else instance
88− ( ServeRoute rest handler m
104+ ( ServeRoute rest handler middlewares m
89 , ServeQuery row list
105 , ServeQuery row list
90 , RowToList row list
106 , RowToList row list
92− ServeRoute (Record row / rest) (Record row -> handler) m where
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
93 serveRoute route@{ query } = do
109 serveRoute route@{ query } = do
94 builder <- serveQuery @row @list query
110 builder <- serveQuery @row @list query
95 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)
114+ ( ServeRoute rest handler middlewares m
116+ , Row.Cons field (Bun.Request -> m x) tail middlewares
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
97−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
98 serveRoute route@{ path } = do
127 serveRoute route@{ path } = do
99 { head: h, tail } <- Array.uncons path
128 { head: h, tail } <- Array.uncons path
100 t <- parsePathPiece @t h
129 t <- parsePathPiece @t h
101− 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)
103−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
104− serveRoute { path, verb } = do
105− assert $ verb == "GET"
107− pure $ \(Nt nt) handler _req -> do
109− pure $ toResponse resp
111−else instance ServeRoute (POST Unit Unit) (m Unit) m where
112− serveRoute { path, verb } = do
113− assert $ verb == "POST"
115− pure $ \(Nt nt) handler _req -> do
118−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
119− serveRoute { path, verb } = do
120− assert $ verb == "POST"
122− pure $ \(Nt nt) handler _req -> do
124− pure $ toResponse resp
125−else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
126− serveRoute { path, verb } = do
127− assert $ verb == "POST"
129− pure $ \(Nt nt) handler req -> do
130− liftAff (fromRequest req) >>= case _ of
131− Nothing -> pure $ badRequest
135−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
136− serveRoute { path, verb } = do
137− assert $ verb == "POST"
139− pure $ \(Nt nt) handler req -> do
140− liftAff (fromRequest req) >>= case _ of
141− Nothing -> pure $ badRequest
143− resp <- nt $ handler r
144− pure $ toResponse resp
146−else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
147− serveRoute { path, verb } = do
148− assert $ verb == "DELETE"
150− pure $ \(Nt nt) handler _req -> do
153−else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
154− serveRoute { path, verb } = do
155− assert $ verb == "DELETE"
157− pure $ \(Nt nt) handler _req -> do
159− pure $ toResponse resp
160−else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
161− serveRoute { path, verb } = do
162− assert $ verb == "DELETE"
164− pure $ \(Nt nt) handler req -> do
165− liftAff (fromRequest req) >>= case _ of
166− Nothing -> pure $ badRequest
170−else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
171− serveRoute { path, verb } = do
172− assert $ verb == "DELETE"
174− pure $ \(Nt nt) handler req -> do
175− liftAff (fromRequest req) >>= case _ of
176− Nothing -> pure $ badRequest
178− resp <- nt $ handler r
179− pure $ toResponse resp
181−else instance ServeRoute (PUT Unit Unit) (m Unit) m where
132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
182 serveRoute { path, verb } = do
133 serveRoute { path, verb } = do
183− assert $ verb == "PUT"
134+ assert $ verb == methodName @(meth Unit Unit)
184 assert $ path == []
135 assert $ path == []
185− pure $ \(Nt nt) handler _req -> do
136+ pure $ \(Nt nt) handler _middlewares _req -> do
186 nt handler
137 nt handler
187 pure $ ok
138 pure $ ok
188−else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where
139+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where
189 serveRoute { path, verb } = do
140 serveRoute { path, verb } = do
190− assert $ verb == "PUT"
141+ assert $ verb == methodName @(meth Unit resp)
191 assert $ path == []
142 assert $ path == []
192− pure $ \(Nt nt) handler _req -> do
143+ pure $ \(Nt nt) handler _middlewares _req -> do
193 resp <- nt handler
144 resp <- nt handler
194 pure $ toResponse resp
145 pure $ toResponse resp
195−else instance (FromRequest req) => ServeRoute (PUT 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
196 serveRoute { path, verb } = do
147 serveRoute { path, verb } = do
197− assert $ verb == "PUT"
148+ assert $ verb == methodName @(meth resp Unit)
198 assert $ path == []
149 assert $ path == []
199− pure $ \(Nt nt) handler req -> do
150+ pure $ \(Nt nt) handler _middlewares req -> do
200 liftAff (fromRequest req) >>= case _ of
151 liftAff (fromRequest req) >>= case _ of
201 Nothing -> pure $ badRequest
152 Nothing -> pure $ badRequest
202 Just r -> do
153 Just r -> do
203 nt $ handler r
154 nt $ handler r
204 pure $ ok
155 pure $ ok
205−else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT 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
206 serveRoute { path, verb } = do
157 serveRoute { path, verb } = do
207− assert $ verb == "PUT"
158+ assert $ verb == methodName @(meth req resp)
208 assert $ path == []
159 assert $ path == []
209− pure $ \(Nt nt) handler req -> do
160+ pure $ \(Nt nt) handler _middlewares req -> do
210 liftAff (fromRequest req) >>= case _ of
161 liftAff (fromRequest req) >>= case _ of
211 Nothing -> pure $ badRequest
162 Nothing -> pure $ badRequest
212 Just r -> do
163 Just r -> do
213 resp <- nt $ handler r
164 resp <- nt $ handler r
214 pure $ toResponse resp
165 pure $ toResponse resp
216−else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
167+else instance
217− serveRoute { path, verb } = do
168+ ( ServeAPI routes list handlers middlewares m
218− assert $ verb == "PATCH"
169+ , RowToList routes list
219− assert $ path == []
170+ ) =>
220− pure $ \(Nt nt) handler _req -> do
171+ ServeRoute routes (Record handlers) middlewares m where
221− nt handler
172+ serveRoute route = pure $ \nt handlers middlewares req ->
222− pure $ ok
173+ serveAPI @routes @list nt handlers middlewares route req
223−else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
224− serveRoute { path, verb } = do
225− assert $ verb == "PATCH"
227− pure $ \(Nt nt) handler _req -> do
229− pure $ toResponse resp
230−else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where
231− serveRoute { path, verb } = do
232− assert $ verb == "PATCH"
234− pure $ \(Nt nt) handler req -> do
235− liftAff (fromRequest req) >>= case _ of
236− Nothing -> pure $ badRequest
240−else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where
241− serveRoute { path, verb } = do
242− assert $ verb == "PATCH"
244− pure $ \(Nt nt) handler req -> do
245− liftAff (fromRequest req) >>= case _ of
246− Nothing -> pure $ badRequest
248− resp <- nt $ handler r
249− pure $ toResponse resp
251class ServeQuery :: Row Type -> RowList Type -> Constraint
175class ServeQuery :: Row Type -> RowList Type -> Constraint
252class ServeQuery row list | list -> row where
176class ServeQuery row list | list -> row where
@@ -304,11 +228,18 @@ else instance
304 r <- serveQuery @tail @rest m
228 r <- serveQuery @tail @rest m
305 pure $ Builder.insert (Proxy @field) v <<< r
229 pure $ Builder.insert (Proxy @field) v <<< r
232+ = JsonResponseBody Json
234+ | StringResponseBody String
236+newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
307class ToResponse r where
238class ToResponse r where
308 toResponse :: r -> Response
239 toResponse :: r -> Response
310instance EncodeJson (Record row) => ToResponse (Record row) where
241instance EncodeJson (Record row) => ToResponse (Record row) where
311− toResponse rec = Response.json (encodeJson rec) { status: 200, statusText: "OK", headers: [] }
242+ toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
313instance ToResponse Response where
244instance ToResponse Response where
314 toResponse resp = resp
245 toResponse resp = resp
@@ -324,6 +255,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
324instance FromRequest Request where
255instance FromRequest Request where
325 fromRequest req = pure $ Just req
256 fromRequest req = pure $ Just req
258+instance FromRequest Unit where
259+ fromRequest _ = pure $ Just unit
265+ FromRequest (Headers (Object header) req) where
266+ fromRequest req = do
267+ r <- fromRequest req
269+ headers <- traverse fromHeader (Request.headers req)
271+ pure $ Headers headers r'
274+ ( RowToList headers headersList
276+ , FromHeaders headers headersList
278+ FromRequest (Headers (Record headers) req) where
279+ fromRequest req = do
280+ r <- fromRequest req
282+ headers <- fromHeaders @headers @headersList (Request.headers req)
284+ pure $ Headers (Builder.buildFromScratch headers) r'
286+class FromHeader t where
287+ fromHeader :: String -> Maybe t
289+instance FromHeader Cookie where
290+ fromHeader = Cookie.parse >>> case _ of
294+instance FromHeader String where
297+instance FromHeader Int where
298+ fromHeader = Int.fromString
300+class FromHeaders :: Row Type -> RowList Type -> Constraint
301+class FromHeaders row list | list -> row where
302+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
304+instance FromHeaders () RowList.Nil where
305+ fromHeaders _ = Just $ identity
310+ , FromHeaders tail rest
311+ , Row.Cons field (Maybe t) tail row
312+ , Row.Lacks field tail
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
321+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
326+ , FromHeaders tail rest
327+ , Row.Cons field t tail row
328+ , Row.Lacks field tail
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
327class ParsePathPiece t where
336class ParsePathPiece t where
328 parsePathPiece :: String -> Maybe t
337 parsePathPiece :: String -> Maybe t
@@ -348,51 +357,54 @@ assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
348assert true = pure unit
357assert true = pure unit
349assert false = empty
358assert false = empty
351−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
352−class ServeAPI row list handlers m | row -> handlers, handlers -> m where
361+class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
353− serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
362+ serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
355−instance ServeAPI row RowList.Nil () m where
364+instance ServeAPI row RowList.Nil () middlewares m where
356− serveAPI _ _ _ _ = pure notFound
365+ serveAPI _ _ _ _ _ = pure notFound
359− ( ServeRoute t handler m
368+ ( ServeRoute t handler middlewares m
360 , Row.Cons field t tail row
369 , Row.Cons field t tail row
361− , ServeAPI row rest restHandlers m
370+ , ServeAPI row rest restHandlers middlewares m
362 , IsSymbol field
371 , IsSymbol field
363 , Row.Cons field handler restHandlers handlers
372 , Row.Cons field handler restHandlers handlers
364 , Row.Lacks field restHandlers
373 , Row.Lacks field restHandlers
366− ServeAPI row (RowList.Cons field t rest) handlers m where
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
367− serveAPI nt handlers route req =
376+ serveAPI nt handlers middlewares route req =
368 case serveRoute @t route of
377 case serveRoute @t route of
369− 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
370− Just f -> f nt (Record.get (Proxy @field) handlers) req
379+ Just f -> f nt (Record.get (Proxy @field) handlers) middlewares req
372notFound :: Response
381notFound :: Response
373−notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
375internalServerError :: Response
384internalServerError :: Response
376−internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }
385+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
378badRequest :: Response
387badRequest :: Response
379−badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
388+badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
381ok :: Response
390ok :: Response
382−ok = Response.string "" { status: 200, statusText: "OK", headers: [] }
391+ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
384-- | 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
385-- | instead you can just pass `identity` as the first argument.
394-- | instead you can just pass `identity` as the first argument.
387− :: forall @row list handlers m
396+ :: forall @row list handlers m middlewares
388 . RowToList row list
397 . RowToList row list
389− => ServeAPI row list handlers m
398+ => ServeAPI row list handlers middlewares m
390 => (forall x. m x -> Server x)
399 => (forall x. m x -> Server x)
391− -> Record handlers
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
392 -> Request
401 -> Request
393− -> Aff Response
402+ -> Aff Bun.Response.Response
394−run nt handlers req = do
403+run nt { handlers, middlewares } req = do
404+ Response { body, headers, status, statusText } <-
395− res <- 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
406+ let opts = { headers, status, statusText }
396− pure case res of
407+ pure $ case body of
397− Left resp -> resp
408+ EmptyResponseBody -> Bun.Response.string "" opts
398− Right resp -> resp
409+ JsonResponseBody json -> Bun.Response.json json opts
410+ StringResponseBody string -> Bun.Response.string string opts