@@ -1,5 +1,7 @@
11module PureStack.Server
22 ( Server
3+ , Response(..)
4+ , ResponseBody(..)
35 , class ToResponse
46 , toResponse
57 , class FromRequest
@@ -18,20 +20,24 @@ module PureStack.Server
1820 , serveQuery
1921 , class ParsePathPiece
2022 , parsePathPiece
23+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
2127 ) where
2228
2329import Prelude
2430import PureStack.Route
2531
2632import Bun.Request (Request)
33+import Bun.Request as Bun
2734import Bun.Request as Request
28−import Bun.Response (Response)
29−import Bun.Response as Response
35+import Bun.Response as Bun.Response
3036import Control.Alternative (class Plus, empty)
3137import 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)
3339import Data.Array as Array
34−import Data.Either (Either(..))
40+import Data.Either (Either(..), either)
3541import Data.Int as Int
3642import Data.Map (Map)
3743import Data.Map as Map
@@ -43,15 +49,24 @@ import Data.Traversable (traverse)
4349import Data.URL as URL
4450import Effect.Aff (Aff)
4551import Effect.Aff.Class (liftAff)
52+import Foreign.Object (Object)
53+import Foreign.Object as Object
4654import Prim.Row as Row
4755import Prim.RowList (class RowToList, RowList)
4856import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
4959import Record as Record
5060import Record.Builder (Builder)
5161import Record.Builder as Builder
5262import Type.Proxy (Proxy(..))
5363
54−type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
64+type Route =
65+ { path :: Array String
66+ , verb :: String
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
69+ }
5570
5671routeFromRequest :: Request -> Route
5772routeFromRequest req =
@@ -68,185 +83,94 @@ routeFromRequest req =
6883 , query: case url of
6984 Nothing -> Map.empty
7085 Just u -> URL.query u
86+ , originalRequest: req
7187 }
7288
7389type Server a = ExceptT Response Aff a
7490
7591newtype Nt m = Nt (forall x. m x -> Server x)
7692
77−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
78−class ServeRoute route handler m | route -> handler, handler -> m where
79− serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
93+class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
94+class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
95+ serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
8096
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
8298 serveRoute route@{ path } = do
8399 { head: h, tail } <- Array.uncons path
84100 assert $ h == (reflectSymbol @path Proxy)
85101 serveRoute @rest route { path = tail }
86102
87103else instance
88− ( ServeRoute rest handler m
104+ ( ServeRoute rest handler middlewares m
89105 , ServeQuery row list
90106 , RowToList row list
91107 ) =>
92− ServeRoute (Record row / rest) (Record row -> handler) m where
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
93109 serveRoute route@{ query } = do
94110 builder <- serveQuery @row @list query
95111 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
96112
97−else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
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+
126+else instance (ServeRoute rest handler middlewares m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) middlewares m where
98127 serveRoute route@{ path } = do
99128 { head: h, tail } <- Array.uncons path
100129 t <- parsePathPiece @t h
101− serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
102−
103−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
104− serveRoute { path, verb } = do
105− assert $ verb == "GET"
106− assert $ path == []
107− pure $ \(Nt nt) handler _req -> do
108− resp <- nt handler
109− pure $ toResponse resp
110−
111−else instance ServeRoute (POST Unit Unit) (m Unit) m where
112− serveRoute { path, verb } = do
113− assert $ verb == "POST"
114− assert $ path == []
115− pure $ \(Nt nt) handler _req -> do
116− nt handler
117− pure $ ok
118−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
119− serveRoute { path, verb } = do
120− assert $ verb == "POST"
121− assert $ path == []
122− pure $ \(Nt nt) handler _req -> do
123− resp <- nt handler
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"
128− assert $ path == []
129− pure $ \(Nt nt) handler req -> do
130− liftAff (fromRequest req) >>= case _ of
131− Nothing -> pure $ badRequest
132− Just r -> do
133− nt $ handler r
134− pure $ ok
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"
138− assert $ path == []
139− pure $ \(Nt nt) handler req -> do
140− liftAff (fromRequest req) >>= case _ of
141− Nothing -> pure $ badRequest
142− Just r -> do
143− resp <- nt $ handler r
144− pure $ toResponse resp
145−
146−else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
147− serveRoute { path, verb } = do
148− assert $ verb == "DELETE"
149− assert $ path == []
150− pure $ \(Nt nt) handler _req -> do
151− nt handler
152− pure $ ok
153−else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
154− serveRoute { path, verb } = do
155− assert $ verb == "DELETE"
156− assert $ path == []
157− pure $ \(Nt nt) handler _req -> do
158− resp <- nt handler
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"
163− assert $ path == []
164− pure $ \(Nt nt) handler req -> do
165− liftAff (fromRequest req) >>= case _ of
166− Nothing -> pure $ badRequest
167− Just r -> do
168− nt $ handler r
169− pure $ ok
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"
173− assert $ path == []
174− pure $ \(Nt nt) handler req -> do
175− liftAff (fromRequest req) >>= case _ of
176− Nothing -> pure $ badRequest
177− Just r -> do
178− resp <- nt $ handler r
179− pure $ toResponse resp
130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
180131
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
182133 serveRoute { path, verb } = do
183− assert $ verb == "PUT"
134+ assert $ verb == methodName @(meth Unit Unit)
184135 assert $ path == []
185− pure $ \(Nt nt) handler _req -> do
136+ pure $ \(Nt nt) handler _middlewares _req -> do
186137 nt handler
187138 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
189140 serveRoute { path, verb } = do
190− assert $ verb == "PUT"
141+ assert $ verb == methodName @(meth Unit resp)
191142 assert $ path == []
192− pure $ \(Nt nt) handler _req -> do
143+ pure $ \(Nt nt) handler _middlewares _req -> do
193144 resp <- nt handler
194145 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
196147 serveRoute { path, verb } = do
197− assert $ verb == "PUT"
148+ assert $ verb == methodName @(meth resp Unit)
198149 assert $ path == []
199− pure $ \(Nt nt) handler req -> do
150+ pure $ \(Nt nt) handler _middlewares req -> do
200151 liftAff (fromRequest req) >>= case _ of
201152 Nothing -> pure $ badRequest
202153 Just r -> do
203154 nt $ handler r
204155 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
206157 serveRoute { path, verb } = do
207− assert $ verb == "PUT"
158+ assert $ verb == methodName @(meth req resp)
208159 assert $ path == []
209− pure $ \(Nt nt) handler req -> do
160+ pure $ \(Nt nt) handler _middlewares req -> do
210161 liftAff (fromRequest req) >>= case _ of
211162 Nothing -> pure $ badRequest
212163 Just r -> do
213164 resp <- nt $ handler r
214165 pure $ toResponse resp
215166
216−else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
217− serveRoute { path, verb } = do
218− assert $ verb == "PATCH"
219− assert $ path == []
220− pure $ \(Nt nt) handler _req -> do
221− nt handler
222− pure $ ok
223−else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
224− serveRoute { path, verb } = do
225− assert $ verb == "PATCH"
226− assert $ path == []
227− pure $ \(Nt nt) handler _req -> do
228− resp <- nt handler
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"
233− assert $ path == []
234− pure $ \(Nt nt) handler req -> do
235− liftAff (fromRequest req) >>= case _ of
236− Nothing -> pure $ badRequest
237− Just r -> do
238− nt $ handler r
239− pure $ ok
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"
243− assert $ path == []
244− pure $ \(Nt nt) handler req -> do
245− liftAff (fromRequest req) >>= case _ of
246− Nothing -> pure $ badRequest
247− Just r -> do
248− resp <- nt $ handler r
249− pure $ toResponse resp
167+else instance
168+ ( ServeAPI routes list handlers middlewares m
169+ , RowToList routes list
170+ ) =>
171+ ServeRoute routes (Record handlers) middlewares m where
172+ serveRoute route = pure $ \nt handlers middlewares req ->
173+ serveAPI @routes @list nt handlers middlewares route req
250174
251175class ServeQuery :: Row Type -> RowList Type -> Constraint
252176class ServeQuery row list | list -> row where
@@ -304,11 +228,18 @@ else instance
304228 r <- serveQuery @tail @rest m
305229 pure $ Builder.insert (Proxy @field) v <<< r
306230
231+data ResponseBody
232+ = JsonResponseBody Json
233+ | EmptyResponseBody
234+ | StringResponseBody String
235+
236+newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
237+
307238class ToResponse r where
308239 toResponse :: r -> Response
309240
310241instance 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 }
312243
313244instance ToResponse Response where
314245 toResponse resp = resp
@@ -324,6 +255,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
324255instance FromRequest Request where
325256 fromRequest req = pure $ Just req
326257
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+
327336class ParsePathPiece t where
328337 parsePathPiece :: String -> Maybe t
329338
@@ -348,51 +357,54 @@ assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
348357assert true = pure unit
349358assert false = empty
350359
351−class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
352−class ServeAPI row list handlers m | row -> handlers, handlers -> m where
353− serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
360+class ServeAPI :: Row Type -> RowList Type -> Row Type -> Row Type -> (Type -> Type) -> Constraint
361+class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
362+ serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
354363
355−instance ServeAPI row RowList.Nil () m where
356− serveAPI _ _ _ _ = pure notFound
364+instance ServeAPI row RowList.Nil () middlewares m where
365+ serveAPI _ _ _ _ _ = pure notFound
357366
358367instance
359− ( ServeRoute t handler m
368+ ( ServeRoute t handler middlewares m
360369 , Row.Cons field t tail row
361− , ServeAPI row rest restHandlers m
370+ , ServeAPI row rest restHandlers middlewares m
362371 , IsSymbol field
363372 , Row.Cons field handler restHandlers handlers
364373 , Row.Lacks field restHandlers
365374 ) =>
366− ServeAPI row (RowList.Cons field t rest) handlers m where
367− serveAPI nt handlers route req =
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
376+ serveAPI nt handlers middlewares route req =
368377 case serveRoute @t route of
369− Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
370− Just f -> f nt (Record.get (Proxy @field) handlers) req
378+ Nothing -> serveAPI @row @rest @restHandlers @middlewares nt (Record.delete (Proxy @field) handlers) middlewares route req
379+ Just f -> f nt (Record.get (Proxy @field) handlers) middlewares req
371380
372381notFound :: Response
373−notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
374383
375384internalServerError :: 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 }
377386
378387badRequest :: Response
379−badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
388+badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
380389
381390ok :: Response
382−ok = Response.string "" { status: 200, statusText: "OK", headers: [] }
391+ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
383392
384393-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
385394-- | instead you can just pass `identity` as the first argument.
386395run
387− :: forall @row list handlers m
396+ :: forall @row list handlers m middlewares
388397 . RowToList row list
389− => ServeAPI row list handlers m
398+ => ServeAPI row list handlers middlewares m
390399 => (forall x. m x -> Server x)
391− -> Record handlers
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
392401 -> Request
393− -> Aff Response
394−run nt handlers req = do
395− res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
396− pure case res of
397− Left resp -> resp
398− Right resp -> resp
402+ -> Aff Bun.Response.Response
403+run nt { handlers, middlewares } req = do
404+ Response { body, headers, status, statusText } <-
405+ map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers middlewares (routeFromRequest req) req
406+ let opts = { headers, status, statusText }
407+ pure $ case body of
408+ EmptyResponseBody -> Bun.Response.string "" opts
409+ JsonResponseBody json -> Bun.Response.json json opts
410+ StringResponseBody string -> Bun.Response.string string opts