@@ -1,410 +0,0 @@
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