@@ -1,101 +1,245 @@
11module PureStack.Server
22 ( Server
3− , serve
3+ , Response(..)
4+ , ResponseBody(..)
5+ , class ToResponse
6+ , toResponse
7+ , class FromRequest
8+ , fromRequest
9+ , run
10+ , notFound
11+ , internalServerError
12+ , badRequest
13+ -------------------------------------------------------------------------------------------------
414 , class ServeAPI
515 , serveAPI
616 , Nt(..)
17+ , class ServeRoute
18+ , serveRoute
19+ , class ServeQuery
20+ , serveQuery
21+ , class ParsePathPiece
22+ , parsePathPiece
23+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
727 ) where
828
929import Prelude
1030import PureStack.Route
1131
1232import Bun.Request (Request)
33+import Bun.Request as Bun
1334import Bun.Request as Request
14−import Bun.Response (Response)
15−import Bun.Response as Response
35+import Bun.Response as Bun.Response
1636import Control.Alternative (class Plus, empty)
17−import Control.Monad.Except (ExceptT, runExceptT, throwError)
18−import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
37+import Control.Monad.Except (ExceptT, runExceptT)
38+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
1939import Data.Array as Array
20−import Data.Either (Either(..))
40+import Data.Either (Either(..), either)
41+import Data.Int as Int
42+import Data.Map (Map)
43+import Data.Map as Map
2144import Data.Maybe (Maybe(..))
45+import Data.Number as Number
46+import Data.String as String
2247import Data.Symbol (class IsSymbol, reflectSymbol)
48+import Data.Traversable (traverse)
2349import Data.URL as URL
24−import Effect (Effect)
2550import Effect.Aff (Aff)
2651import Effect.Aff.Class (liftAff)
27−import Prim.Row (class Lacks)
52+import Foreign.Object (Object)
53+import Foreign.Object as Object
2854import Prim.Row as Row
2955import Prim.RowList (class RowToList, RowList)
3056import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
3159import Record as Record
60+import Record.Builder (Builder)
61+import Record.Builder as Builder
3262import Type.Proxy (Proxy(..))
3363
34−type Route = { path :: Array String, verb :: String }
64+type Route =
65+ { path :: Array String
66+ , verb :: String
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
69+ }
3570
3671routeFromRequest :: Request -> Route
3772routeFromRequest req =
38− { verb: Request.method req
39− , path: case URL.fromString (Request.url req) of
40− Nothing -> []
41− Just url -> case URL.path url of
42− URL.PathEmpty -> []
43− URL.PathAbsolute p -> p
44− URL.PathRelative p -> p
45− }
73+ let
74+ url = URL.fromString $ Request.url req
75+ in
76+ { verb: Request.method req
77+ , path: case url of
78+ Nothing -> []
79+ Just u -> case URL.path u of
80+ URL.PathEmpty -> []
81+ URL.PathAbsolute p -> p
82+ URL.PathRelative p -> p
83+ , query: case url of
84+ Nothing -> Map.empty
85+ Just u -> URL.query u
86+ , originalRequest: req
87+ }
4688
4789type Server a = ExceptT Response Aff a
4890
4991newtype Nt m = Nt (forall x. m x -> Server x)
5092
51−class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
52−class ServeRoute route handler m | route -> handler, handler -> m where
53− 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)
5496
55−instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
56− serveRoute { path, verb } = do
97+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
98+ serveRoute route@{ path } = do
5799 { head: h, tail } <- Array.uncons path
58100 assert $ h == (reflectSymbol @path Proxy)
59− serveRoute @rest { path: tail, verb: verb }
101+ serveRoute @rest route { path = tail }
60102
61−else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
62− serveRoute { path, verb } = do
103+else instance
104+ ( ServeRoute rest handler middlewares m
105+ , ServeQuery row list
106+ , RowToList row list
107+ ) =>
108+ ServeRoute (Record row / rest) (Record row -> handler) middlewares m where
109+ serveRoute route@{ query } = do
110+ builder <- serveQuery @row @list query
111+ serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
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+
126+else instance (ServeRoute rest handler middlewares m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) middlewares m where
127+ serveRoute route@{ path } = do
63128 { head: h, tail } <- Array.uncons path
64129 t <- parsePathPiece @t h
65− serveRoute @rest { path: tail, verb } <#> (\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)
66131
67−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
68133 serveRoute { path, verb } = do
69− assert $ verb == "GET"
134+ assert $ verb == methodName @(meth Unit Unit)
70135 assert $ path == []
71− pure $ \(Nt nt) handler _req -> do
72− resp <- nt handler
73− pure $ toResponse resp
74−
75−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
136+ pure $ \(Nt nt) handler _middlewares _req -> do
137+ nt handler
138+ pure $ ok
139+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) middlewares m where
76140 serveRoute { path, verb } = do
141+ assert $ verb == methodName @(meth Unit resp)
77142 assert $ path == []
78− assert $ verb == "POST"
79− pure $ \(Nt nt) handler _req -> do
143+ pure $ \(Nt nt) handler _middlewares _req -> do
80144 resp <- nt handler
81145 pure $ toResponse resp
82−
83−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
146+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where
147+ serveRoute { path, verb } = do
148+ assert $ verb == methodName @(meth resp Unit)
149+ assert $ path == []
150+ pure $ \(Nt nt) handler _middlewares req -> do
151+ liftAff (fromRequest req) >>= case _ of
152+ Nothing -> pure $ badRequest
153+ Just r -> do
154+ nt $ handler r
155+ pure $ ok
156+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) middlewares m where
84157 serveRoute { path, verb } = do
158+ assert $ verb == methodName @(meth req resp)
85159 assert $ path == []
86− assert $ verb == "POST"
87− pure $ \(Nt nt) handler req -> do
160+ pure $ \(Nt nt) handler _middlewares req -> do
88161 liftAff (fromRequest req) >>= case _ of
89162 Nothing -> pure $ badRequest
90163 Just r -> do
91164 resp <- nt $ handler r
92165 pure $ toResponse resp
93166
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
174+
175+class ServeQuery :: Row Type -> RowList Type -> Constraint
176+class ServeQuery row list | list -> row where
177+ serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
178+
179+instance ServeQuery () RowList.Nil where
180+ serveQuery _ = Just $ identity
181+
182+instance
183+ ( ParsePathPiece t
184+ , ServeQuery tail rest
185+ , IsSymbol field
186+ , Row.Cons field (Array t) tail row
187+ , Row.Lacks field tail
188+ ) =>
189+ ServeQuery row (RowList.Cons field (Array t) rest) where
190+ serveQuery m = do
191+ r <- serveQuery @tail @rest m
192+ case Map.lookup (reflectSymbol @field Proxy) m of
193+ Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
194+ Just a -> do
195+ v <- parsePathPiece @t `traverse` a
196+ pure $ Builder.insert (Proxy @field) v <<< r
197+
198+else instance
199+ ( ParsePathPiece t
200+ , ServeQuery tail rest
201+ , IsSymbol field
202+ , Row.Cons field (Maybe t) tail row
203+ , Row.Lacks field tail
204+ ) =>
205+ ServeQuery row (RowList.Cons field (Maybe t) rest) where
206+ serveQuery m = do
207+ r <- serveQuery @tail @rest m
208+ case Map.lookup (reflectSymbol @field Proxy) m of
209+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
210+ Just a -> do
211+ { head, tail } <- Array.uncons a
212+ assert $ tail == []
213+ v <- parsePathPiece @t head
214+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
215+
216+else instance
217+ ( ParsePathPiece t
218+ , ServeQuery tail rest
219+ , IsSymbol field
220+ , Row.Cons field t tail row
221+ , Row.Lacks field tail
222+ ) =>
223+ ServeQuery row (RowList.Cons field t rest) where
224+ serveQuery m = do
225+ { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
226+ assert $ tail == []
227+ v <- parsePathPiece @t head
228+ r <- serveQuery @tail @rest m
229+ pure $ Builder.insert (Proxy @field) v <<< r
230+
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+
94238class ToResponse r where
95239 toResponse :: r -> Response
96240
97241instance EncodeJson (Record row) => ToResponse (Record row) where
98− 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 }
99243
100244instance ToResponse Response where
101245 toResponse resp = resp
@@ -111,106 +255,156 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
111255instance FromRequest Request where
112256 fromRequest req = pure $ Just req
113257
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+
114336class ParsePathPiece t where
115337 parsePathPiece :: String -> Maybe t
116338
339+instance ParsePathPiece String where
340+ parsePathPiece = Just
341+
342+instance ParsePathPiece Int where
343+ parsePathPiece = Int.fromString
344+
345+instance ParsePathPiece Number where
346+ parsePathPiece = Number.fromString
347+
348+instance ParsePathPiece Boolean where
349+ parsePathPiece s = case String.toLower s of
350+ "true" -> Just true
351+ "1" -> Just true
352+ "false" -> Just false
353+ "0" -> Just false
354+ _ -> Nothing
355+
117356assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
118357assert true = pure unit
119358assert false = empty
120359
121−class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
122−class ServeAPI row list handlers m | row -> handlers, handlers -> m where
123− 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
124363
125−instance ServeAPI row RowList.Nil () m where
126− serveAPI _ _ _ _ = pure notFound
364+instance ServeAPI row RowList.Nil () middlewares m where
365+ serveAPI _ _ _ _ _ = pure notFound
127366
128367instance
129− ( ServeRoute t handler m
368+ ( ServeRoute t handler middlewares m
130369 , Row.Cons field t tail row
131− , ServeAPI row rest restHandlers m
370+ , ServeAPI row rest restHandlers middlewares m
132371 , IsSymbol field
133372 , Row.Cons field handler restHandlers handlers
134373 , Row.Lacks field restHandlers
135374 ) =>
136− ServeAPI row (RowList.Cons field t rest) handlers m where
137− serveAPI nt handlers route@{ path, verb } req =
138− case serveRoute @t { path, verb } of
139− Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
140− Just f -> f nt (Record.get (Proxy @field) handlers) req
375+ ServeAPI row (RowList.Cons field t rest) handlers middlewares m where
376+ serveAPI nt handlers middlewares route req =
377+ case serveRoute @t route of
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
141380
142381notFound :: Response
143−notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
144383
145384internalServerError :: Response
146−internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }
385+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
147386
148387badRequest :: Response
149−badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
388+badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
389+
390+ok :: Response
391+ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
150392
151−serve
152− :: forall @row list handlers m
393+-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
394+-- | instead you can just pass `identity` as the first argument.
395+run
396+ :: forall @row list handlers m middlewares
153397 . RowToList row list
154− => ServeAPI row list handlers m
398+ => ServeAPI row list handlers middlewares m
155399 => (forall x. m x -> Server x)
156− -> Record handlers
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
157401 -> Request
158− -> Aff Response
159−serve nt handlers req = do
160− res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
161− pure case res of
162− Left resp -> resp
163− Right resp -> resp
164−
165−-- class RecordNaturalTransformation
166−-- :: forall k
167−-- . (k -> Type)
168−-- -> (k -> Type)
169−-- -> Row Type
170−-- -> RowList Type
171−-- -> Row Type
172−-- -> Constraint
173−-- class
174−-- RecordNaturalTransformation from to row list row'
175−-- | list from -> row
176−-- , list to -> row'
177−-- , row' from -> row
178−-- , row to -> row where
179−-- nt' :: (forall a. from a -> to a) -> Record row -> Record row'
180−
181−-- instance RecordNaturalTransformation from to () RowList.Nil () where
182−-- nt' _ rec = rec
183−
184−-- instance
185−-- ( IsSymbol field
186−-- , Row.Cons field t tail row
187−-- , Row.Cons field t' tail' row'
188−-- , FunctionNaturalTransformation from to t t'
189−-- , RecordNaturalTransformation from to tail rest tail'
190−-- , Lacks field tail
191−-- , Lacks field tail'
192−-- ) =>
193−-- RecordNaturalTransformation from to row (RowList.Cons field t rest) row' where
194−-- nt' f rec = Record.insert (Proxy @field) (ntFunction f $ Record.get (Proxy @field) rec)
195−-- $ nt' @from @to @tail @rest @tail' f (Record.delete (Proxy @field) rec)
196−
197−-- class FunctionNaturalTransformation :: forall k. (k -> Type) -> (k -> Type) -> Type -> Type -> Constraint
198−-- class FunctionNaturalTransformation from to func func' | to func -> func' where
199−-- ntFunction :: (forall a. from a -> to a) -> func -> func'
200−
201−-- instance FunctionNaturalTransformation from to (from x) (to x) where
202−-- ntFunction f g = f g
203−
204−-- else instance
205−-- FunctionNaturalTransformation from to func func' =>
206−-- FunctionNaturalTransformation from to (a -> func) (a -> func') where
207−-- ntFunction f g = \a -> ntFunction f (g a)
208−
209−-- nt
210−-- :: forall @from row row' list
211−-- . RowToList row list
212−-- => RecordNaturalTransformation from Aff row list row'
213−-- => (forall a. from a -> Aff a)
214−-- -> Record row
215−-- -> Record row'
216−-- nt f rec = nt' @from @Aff @row @list @row' f rec
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