@@ -0,0 +1,410 @@
1+module PureStack.Server
2+ ( Server
3+ , Response(..)
4+ , ResponseBody(..)
5+ , class ToResponse
6+ , toResponse
7+ , class FromRequest
8+ , fromRequest
9+ , run
10+ , notFound
11+ , internalServerError
12+ , badRequest
13+ -------------------------------------------------------------------------------------------------
14+ , class ServeAPI
15+ , serveAPI
16+ , 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
27+ ) where
28+
29+import Prelude
30+import PureStack.Route
31+
32+import Bun.Request (Request)
33+import Bun.Request as Bun
34+import Bun.Request as Request
35+import Bun.Response as Bun.Response
36+import Control.Alternative (class Plus, empty)
37+import Control.Monad.Except (ExceptT, runExceptT)
38+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
39+import Data.Array as Array
40+import Data.Either (Either(..), either)
41+import Data.Int as Int
42+import Data.Map (Map)
43+import Data.Map as Map
44+import Data.Maybe (Maybe(..))
45+import Data.Number as Number
46+import Data.String as String
47+import Data.Symbol (class IsSymbol, reflectSymbol)
48+import Data.Traversable (traverse)
49+import Data.URL as URL
50+import Effect.Aff (Aff)
51+import Effect.Aff.Class (liftAff)
52+import Foreign.Object (Object)
53+import Foreign.Object as Object
54+import Prim.Row as Row
55+import Prim.RowList (class RowToList, RowList)
56+import Prim.RowList as RowList
57+import PureStack.Cookie (Cookie)
58+import PureStack.Cookie as Cookie
59+import Record as Record
60+import Record.Builder (Builder)
61+import Record.Builder as Builder
62+import Type.Proxy (Proxy(..))
63+
64+type Route =
65+ { path :: Array String
66+ , verb :: String
67+ , query :: Map String (Array String)
68+ , originalRequest :: Bun.Request
69+ }
70+
71+routeFromRequest :: Request -> Route
72+routeFromRequest req =
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+ }
88+
89+type Server a = ExceptT Response Aff a
90+
91+newtype Nt m = Nt (forall x. m x -> Server x)
92+
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)
96+
97+instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
98+ serveRoute route@{ path } = do
99+ { head: h, tail } <- Array.uncons path
100+ assert $ h == (reflectSymbol @path Proxy)
101+ serveRoute @rest route { path = tail }
102+
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
128+ { head: h, tail } <- Array.uncons path
129+ t <- parsePathPiece @t h
130+ serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
131+
132+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) middlewares m where
133+ serveRoute { path, verb } = do
134+ assert $ verb == methodName @(meth Unit Unit)
135+ assert $ path == []
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
140+ serveRoute { path, verb } = do
141+ assert $ verb == methodName @(meth Unit resp)
142+ assert $ path == []
143+ pure $ \(Nt nt) handler _middlewares _req -> do
144+ resp <- nt handler
145+ pure $ toResponse resp
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
157+ serveRoute { path, verb } = do
158+ assert $ verb == methodName @(meth req resp)
159+ assert $ path == []
160+ pure $ \(Nt nt) handler _middlewares req -> do
161+ liftAff (fromRequest req) >>= case _ of
162+ Nothing -> pure $ badRequest
163+ Just r -> do
164+ resp <- nt $ handler r
165+ pure $ toResponse resp
166+
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+
238+class ToResponse r where
239+ toResponse :: r -> Response
240+
241+instance EncodeJson (Record row) => ToResponse (Record row) where
242+ toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
243+
244+instance ToResponse Response where
245+ toResponse resp = resp
246+
247+class FromRequest r where
248+ fromRequest :: Request -> Aff (Maybe r)
249+
250+instance DecodeJson (Record row) => FromRequest (Record row) where
251+ fromRequest req = Request.json req <#> \j -> case decodeJson j of
252+ Right r -> Just r
253+ Left _ -> Nothing
254+
255+instance FromRequest Request where
256+ fromRequest req = pure $ Just req
257+
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+
336+class ParsePathPiece t where
337+ parsePathPiece :: String -> Maybe t
338+
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+
356+assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
357+assert true = pure unit
358+assert false = empty
359+
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
363+
364+instance ServeAPI row RowList.Nil () middlewares m where
365+ serveAPI _ _ _ _ _ = pure notFound
366+
367+instance
368+ ( ServeRoute t handler middlewares m
369+ , Row.Cons field t tail row
370+ , ServeAPI row rest restHandlers middlewares m
371+ , IsSymbol field
372+ , Row.Cons field handler restHandlers handlers
373+ , Row.Lacks field restHandlers
374+ ) =>
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
380+
381+notFound :: Response
382+notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
383+
384+internalServerError :: Response
385+internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
386+
387+badRequest :: Response
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 }
392+
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
397+ . RowToList row list
398+ => ServeAPI row list handlers middlewares m
399+ => (forall x. m x -> Server x)
400+ -> { handlers :: Record handlers, middlewares :: Record middlewares }
401+ -> Request
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