git.iko.soy/purestack-dev/purescript-purestack-server
on master help sign in
purestack-dev/purescript-purestack-server/src/PureStack/Server.purs
410 lines 14 kB history raw
1module 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
29import Prelude
30import PureStack.Route
32import Bun.Request (Request)
33import Bun.Request as Bun
34import Bun.Request as Request
35import Bun.Response as Bun.Response
36import Control.Alternative (class Plus, empty)
37import Control.Monad.Except (ExceptT, runExceptT)
38import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
39import Data.Array as Array
40import Data.Either (Either(..), either)
41import Data.Int as Int
42import Data.Map (Map)
43import Data.Map as Map
44import Data.Maybe (Maybe(..))
45import Data.Number as Number
46import Data.String as String
47import Data.Symbol (class IsSymbol, reflectSymbol)
48import Data.Traversable (traverse)
49import Data.URL as URL
50import Effect.Aff (Aff)
51import Effect.Aff.Class (liftAff)
52import Foreign.Object (Object)
53import Foreign.Object as Object
54import Prim.Row as Row
55import Prim.RowList (class RowToList, RowList)
56import Prim.RowList as RowList
57import PureStack.Cookie (Cookie)
58import PureStack.Cookie as Cookie
59import Record as Record
60import Record.Builder (Builder)
61import Record.Builder as Builder
62import Type.Proxy (Proxy(..))
64type Route =
65 { path :: Array String
66 , verb :: String
67 , query :: Map String (Array String)
68 , originalRequest :: Bun.Request
69 }
71routeFromRequest :: Request -> Route
72routeFromRequest 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 }
89type Server a = ExceptT Response Aff a
91newtype Nt m = Nt (forall x. m x -> Server x)
93class ServeRoute :: forall k. k -> Type -> Row Type -> (Type -> Type) -> Constraint
94class ServeRoute route handler middlewares m | route middlewares -> handler, handler -> m where
95 serveRoute :: Route -> Maybe (Nt m -> handler -> Record middlewares -> Request -> Server Response)
97instance (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 }
103else 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)
113else 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 )
126else 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)
132else 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
139else 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
146else 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
156else 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
167else 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
175class ServeQuery :: Row Type -> RowList Type -> Constraint
176class ServeQuery row list | list -> row where
177 serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
179instance ServeQuery () RowList.Nil where
180 serveQuery _ = Just $ identity
182instance
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
198else 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
216else 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
231data ResponseBody
232 = JsonResponseBody Json
233 | EmptyResponseBody
234 | StringResponseBody String
236newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
238class ToResponse r where
239 toResponse :: r -> Response
241instance EncodeJson (Record row) => ToResponse (Record row) where
242 toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
244instance ToResponse Response where
245 toResponse resp = resp
247class FromRequest r where
248 fromRequest :: Request -> Aff (Maybe r)
250instance 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
255instance FromRequest Request where
256 fromRequest req = pure $ Just req
258instance FromRequest Unit where
259 fromRequest _ = pure $ Just unit
261instance
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'
273instance
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'
286class FromHeader t where
287 fromHeader :: String -> Maybe t
289instance FromHeader Cookie where
290 fromHeader = Cookie.parse >>> case _ of
291 Left _ -> Nothing
292 Right x -> Just x
294instance FromHeader String where
295 fromHeader = Just
297instance FromHeader Int where
298 fromHeader = Int.fromString
300class FromHeaders :: Row Type -> RowList Type -> Constraint
301class FromHeaders row list | list -> row where
302 fromHeaders :: Object String -> Maybe (Builder {} (Record row))
304instance FromHeaders () RowList.Nil where
305 fromHeaders _ = Just $ identity
307instance
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
323else 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
336class ParsePathPiece t where
337 parsePathPiece :: String -> Maybe t
339instance ParsePathPiece String where
340 parsePathPiece = Just
342instance ParsePathPiece Int where
343 parsePathPiece = Int.fromString
345instance ParsePathPiece Number where
346 parsePathPiece = Number.fromString
348instance 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
356assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
357assert true = pure unit
358assert false = empty
360class ServeAPI :: Row Type -> RowList Type -> Row Type -> Row Type -> (Type -> Type) -> Constraint
361class ServeAPI row list handlers middlewares m | row -> handlers, handlers -> m where
362 serveAPI :: Nt m -> Record handlers -> Record middlewares -> Route -> Request -> Server Response
364instance ServeAPI row RowList.Nil () middlewares m where
365 serveAPI _ _ _ _ _ = pure notFound
367instance
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
381notFound :: Response
382notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
384internalServerError :: Response
385internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
387badRequest :: Response
388badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
390ok :: Response
391ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
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.
395run
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
403run 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