@@ -20,12 +20,17 @@ module PureStack.Server
2020 , serveQuery
2121 , class ParsePathPiece
2222 , parsePathPiece
23+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
2327 ) where
2428
2529import Prelude
2630import PureStack.Route
2731
2832import Bun.Request (Request)
33+import Bun.Request as Bun
2934import Bun.Request as Request
3035import Bun.Response as Bun.Response
3136import Control.Alternative (class Plus, empty)
@@ -49,12 +54,19 @@ import Foreign.Object as Object
4954import Prim.Row as Row
5055import Prim.RowList (class RowToList, RowList)
5156import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
5259import Record as Record
5360import Record.Builder (Builder)
5461import Record.Builder as Builder
5562import Type.Proxy (Proxy(..))
5663
57−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+ }
5870
5971routeFromRequest :: Request -> Route
6072routeFromRequest req =
@@ -71,180 +83,81 @@ routeFromRequest req =
7183 , query: case url of
7284 Nothing -> Map.empty
7385 Just u -> URL.query u
86+ , originalRequest: req
7487 }
7588
7689type Server a = ExceptT Response Aff a
7790
7891newtype Nt m = Nt (forall x. m x -> Server x)
7992
80−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
81−class ServeRoute route handler m | route -> handler, handler -> m where
82− 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)
8396
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
8598 serveRoute route@{ path } = do
8699 { head: h, tail } <- Array.uncons path
87100 assert $ h == (reflectSymbol @path Proxy)
88101 serveRoute @rest route { path = tail }
89102
90103else instance
91− ( ServeRoute rest handler m
104+ ( ServeRoute rest handler middlewares m
92105 , ServeQuery row list
93106 , RowToList row list
94107 ) =>
95− ServeRoute (Record row / rest) (Record row -> handler) m where
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
96109 serveRoute route@{ query } = do
97110 builder <- serveQuery @row @list query
98111 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
99112
100−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
101127 serveRoute route@{ path } = do
102128 { head: h, tail } <- Array.uncons path
103129 t <- parsePathPiece @t h
104− serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) 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
130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
148131
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
150133 serveRoute { path, verb } = do
151− assert $ verb == "DELETE"
134+ assert $ verb == methodName @(meth Unit Unit)
152135 assert $ path == []
153− pure $ \(Nt nt) handler _req -> do
136+ pure $ \(Nt nt) handler _middlewares _req -> do
154137 nt handler
155138 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
157140 serveRoute { path, verb } = do
158− assert $ verb == "DELETE"
141+ assert $ verb == methodName @(meth Unit resp)
159142 assert $ path == []
160− pure $ \(Nt nt) handler _req -> do
143+ pure $ \(Nt nt) handler _middlewares _req -> do
161144 resp <- nt handler
162145 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
164147 serveRoute { path, verb } = do
165− assert $ verb == "DELETE"
148+ assert $ verb == methodName @(meth resp Unit)
166149 assert $ path == []
167− pure $ \(Nt nt) handler req -> do
150+ pure $ \(Nt nt) handler _middlewares req -> do
168151 liftAff (fromRequest req) >>= case _ of
169152 Nothing -> pure $ badRequest
170153 Just r -> do
171154 nt $ handler r
172155 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
174157 serveRoute { path, verb } = do
175− assert $ verb == "DELETE"
158+ assert $ verb == methodName @(meth req resp)
176159 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 == []
247− pure $ \(Nt nt) handler req -> do
160+ pure $ \(Nt nt) handler _middlewares req -> do
248161 liftAff (fromRequest req) >>= case _ of
249162 Nothing -> pure $ badRequest
250163 Just r -> do
@@ -252,12 +165,12 @@ else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp)
252165 pure $ toResponse resp
253166
254167else instance
255− ( ServeAPI routes list handlers m
168+ ( ServeAPI routes list handlers middlewares m
256169 , RowToList routes list
257170 ) =>
258− ServeRoute routes (Record handlers) m where
259− serveRoute route = pure $ \nt handlers req ->
260− serveAPI @routes @list nt handlers route req
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
261174
262175class ServeQuery :: Row Type -> RowList Type -> Constraint
263176class ServeQuery row list | list -> row where
@@ -342,6 +255,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
342255instance FromRequest Request where
343256 fromRequest req = pure $ Just req
344257
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+
345336class ParsePathPiece t where
346337 parsePathPiece :: String -> Maybe t
347338
@@ -366,26 +357,26 @@ assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
366357assert true = pure unit
367358assert false = empty
368359
369−class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
370−class ServeAPI row list handlers m | row -> handlers, handlers -> m where
371− 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
372363
373−instance ServeAPI row RowList.Nil () m where
374− serveAPI _ _ _ _ = pure notFound
364+instance ServeAPI row RowList.Nil () middlewares m where
365+ serveAPI _ _ _ _ _ = pure notFound
375366
376367instance
377− ( ServeRoute t handler m
368+ ( ServeRoute t handler middlewares m
378369 , Row.Cons field t tail row
379− , ServeAPI row rest restHandlers m
370+ , ServeAPI row rest restHandlers middlewares m
380371 , IsSymbol field
381372 , Row.Cons field handler restHandlers handlers
382373 , Row.Lacks field restHandlers
383374 ) =>
384− ServeAPI row (RowList.Cons field t rest) handlers m where
385− serveAPI nt handlers route req =
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
376+ serveAPI nt handlers middlewares route req =
386377 case serveRoute @t route of
387− Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
388− 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
389380
390381notFound :: Response
391382notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
@@ -402,16 +393,16 @@ ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers:
402393-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
403394-- | instead you can just pass `identity` as the first argument.
404395run
405− :: forall @row list handlers m
396+ :: forall @row list handlers m middlewares
406397 . RowToList row list
407− => ServeAPI row list handlers m
398+ => ServeAPI row list handlers middlewares m
408399 => (forall x. m x -> Server x)
409− -> Record handlers
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
410401 -> Request
411402 -> Aff Bun.Response.Response
412−run nt handlers req = do
403+run nt { handlers, middlewares } req = do
413404 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
415406 let opts = { headers, status, statusText }
416407 pure $ case body of
417408 EmptyResponseBody -> Bun.Response.string "" opts