@@ -1,245 +1,101 @@
11module PureStack.Server
22 ( Server
3− , Response(..)
4− , ResponseBody(..)
5− , class ToResponse
6− , toResponse
7− , class FromRequest
8− , fromRequest
9− , run
10− , notFound
11− , internalServerError
12− , badRequest
13− -------------------------------------------------------------------------------------------------
3+ , serve
144 , class ServeAPI
155 , serveAPI
166 , 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
277 ) where
288
299import Prelude
3010import PureStack.Route
3111
3212import Bun.Request (Request)
33−import Bun.Request as Bun
3413import Bun.Request as Request
35−import Bun.Response as Bun.Response
14+import Bun.Response (Response)
15+import Bun.Response as Response
3616import Control.Alternative (class Plus, empty)
37−import Control.Monad.Except (ExceptT, runExceptT)
38−import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
17+import Control.Monad.Except (ExceptT, runExceptT, throwError)
18+import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
3919import 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
20+import Data.Either (Either(..))
4421import Data.Maybe (Maybe(..))
45−import Data.Number as Number
46−import Data.String as String
4722import Data.Symbol (class IsSymbol, reflectSymbol)
48−import Data.Traversable (traverse)
4923import Data.URL as URL
24+import Effect (Effect)
5025import Effect.Aff (Aff)
5126import Effect.Aff.Class (liftAff)
52−import Foreign.Object (Object)
53−import Foreign.Object as Object
27+import Prim.Row (class Lacks)
5428import Prim.Row as Row
5529import Prim.RowList (class RowToList, RowList)
5630import Prim.RowList as RowList
57−import PureStack.Cookie (Cookie)
58−import PureStack.Cookie as Cookie
5931import Record as Record
60−import Record.Builder (Builder)
61−import Record.Builder as Builder
6232import Type.Proxy (Proxy(..))
6333
64−type Route =
65− { path :: Array String
66− , verb :: String
67− , query :: Map String (Array String)
68− , originalRequest :: Bun.Request
69− }
34+type Route = { path :: Array String, verb :: String }
7035
7136routeFromRequest :: Request -> Route
7237routeFromRequest 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− }
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+ }
8846
8947type Server a = ExceptT Response Aff a
9048
9149newtype Nt m = Nt (forall x. m x -> Server x)
9250
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)
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)
9654
97−instance (ServeRoute rest handler middlewares m, IsSymbol path) => ServeRoute (path / rest) handler middlewares m where
98− serveRoute route@{ path } = do
55+instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
56+ serveRoute { path, verb } = do
9957 { head: h, tail } <- Array.uncons path
10058 assert $ h == (reflectSymbol @path Proxy)
101− serveRoute @rest route { path = tail }
59+ serveRoute @rest { path: tail, verb: verb }
10260
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
61+else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
62+ serveRoute { path, verb } = do
12863 { head: h, tail } <- Array.uncons path
12964 t <- parsePathPiece @t h
130− serveRoute @rest route { path = tail } <#> (\f nt handler mws req -> f nt (handler t) mws req)
65+ serveRoute @rest { path: tail, verb } <#> (\f nt handler req -> f nt (handler t) req)
13166
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
67+else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
14068 serveRoute { path, verb } = do
141− assert $ verb == methodName @(meth Unit resp)
69+ assert $ verb == "GET"
14270 assert $ path == []
143− pure $ \(Nt nt) handler _middlewares _req -> do
71+ pure $ \(Nt nt) handler _req -> do
14472 resp <- nt handler
14573 pure $ toResponse resp
146−else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where
74+
75+else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
14776 serveRoute { path, verb } = do
148− assert $ verb == methodName @(meth resp Unit)
14977 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
78+ assert $ verb == "POST"
79+ pure $ \(Nt nt) handler _req -> do
80+ resp <- nt handler
81+ pure $ toResponse resp
82+
83+else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
15784 serveRoute { path, verb } = do
158− assert $ verb == methodName @(meth req resp)
15985 assert $ path == []
160− pure $ \(Nt nt) handler _middlewares req -> do
86+ assert $ verb == "POST"
87+ pure $ \(Nt nt) handler req -> do
16188 liftAff (fromRequest req) >>= case _ of
16289 Nothing -> pure $ badRequest
16390 Just r -> do
16491 resp <- nt $ handler r
16592 pure $ toResponse resp
16693
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−
23894class ToResponse r where
23995 toResponse :: r -> Response
24096
24197instance EncodeJson (Record row) => ToResponse (Record row) where
242− toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
98+ toResponse rec = Response.json (encodeJson rec) { status: 200, statusText: "OK", headers: [] }
24399
244100instance ToResponse Response where
245101 toResponse resp = resp
@@ -255,156 +111,106 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
255111instance FromRequest Request where
256112 fromRequest req = pure $ Just req
257113
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−
336114class ParsePathPiece t where
337115 parsePathPiece :: String -> Maybe t
338116
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−
356117assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
357118assert true = pure unit
358119assert false = empty
359120
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
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
363124
364−instance ServeAPI row RowList.Nil () middlewares m where
365− serveAPI _ _ _ _ _ = pure notFound
125+instance ServeAPI row RowList.Nil () m where
126+ serveAPI _ _ _ _ = pure notFound
366127
367128instance
368− ( ServeRoute t handler middlewares m
129+ ( ServeRoute t handler m
369130 , Row.Cons field t tail row
370− , ServeAPI row rest restHandlers middlewares m
131+ , ServeAPI row rest restHandlers m
371132 , IsSymbol field
372133 , Row.Cons field handler restHandlers handlers
373134 , Row.Lacks field restHandlers
374135 ) =>
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
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
380141
381142notFound :: Response
382−notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
143+notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
383144
384145internalServerError :: Response
385−internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
146+internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }
386147
387148badRequest :: 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 }
149+badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
392150
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
151+serve
152+ :: forall @row list handlers m
397153 . RowToList row list
398− => ServeAPI row list handlers middlewares m
154+ => ServeAPI row list handlers m
399155 => (forall x. m x -> Server x)
400− -> { handlers :: Record handlers, middlewares :: Record middlewares }
156+ -> Record handlers
401157 -> 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
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