git.iko.soy/purestack-dev/purescript-purestack-server
on 8935650 help sign in
purestack-dev/purescript-purestack-server/src/PureStack/Server.purs
406 lines 13 kB history raw
1module PureStack.Server
2 ( Server
3 , class ToResponse
4 , toResponse
5 , class FromRequest
6 , fromRequest
7 , run
8 , notFound
9 , internalServerError
10 , badRequest
11 -------------------------------------------------------------------------------------------------
12 , class ServeAPI
13 , serveAPI
14 , Nt(..)
15 , class ServeRoute
16 , serveRoute
17 , class ServeQuery
18 , serveQuery
19 , class ParsePathPiece
20 , parsePathPiece
21 ) where
23import Prelude
24import PureStack.Route
26import Bun.Request (Request)
27import Bun.Request as Request
28import Bun.Response (Response)
29import Bun.Response as Response
30import Control.Alternative (class Plus, empty)
31import Control.Monad.Except (ExceptT, runExceptT)
32import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
33import Data.Array as Array
34import Data.Either (Either(..))
35import Data.Int as Int
36import Data.Map (Map)
37import Data.Map as Map
38import Data.Maybe (Maybe(..))
39import Data.Number as Number
40import Data.String as String
41import Data.Symbol (class IsSymbol, reflectSymbol)
42import Data.Traversable (traverse)
43import Data.URL as URL
44import Effect.Aff (Aff)
45import Effect.Aff.Class (liftAff)
46import Prim.Row as Row
47import Prim.RowList (class RowToList, RowList)
48import Prim.RowList as RowList
49import Record as Record
50import Record.Builder (Builder)
51import Record.Builder as Builder
52import Type.Proxy (Proxy(..))
54type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
56routeFromRequest :: Request -> Route
57routeFromRequest req =
58 let
59 url = URL.fromString $ Request.url req
60 in
61 { verb: Request.method req
62 , path: case url of
63 Nothing -> []
64 Just u -> case URL.path u of
65 URL.PathEmpty -> []
66 URL.PathAbsolute p -> p
67 URL.PathRelative p -> p
68 , query: case url of
69 Nothing -> Map.empty
70 Just u -> URL.query u
71 }
73type Server a = ExceptT Response Aff a
75newtype Nt m = Nt (forall x. m x -> Server x)
77class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
78class ServeRoute route handler m | route -> handler, handler -> m where
79 serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
81instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
82 serveRoute route@{ path } = do
83 { head: h, tail } <- Array.uncons path
84 assert $ h == (reflectSymbol @path Proxy)
85 serveRoute @rest route { path = tail }
87else instance
88 ( ServeRoute rest handler m
89 , ServeQuery row list
90 , RowToList row list
91 ) =>
92 ServeRoute (Record row / rest) (Record row -> handler) m where
93 serveRoute route@{ query } = do
94 builder <- serveQuery @row @list query
95 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
97else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
98 serveRoute route@{ path } = do
99 { head: h, tail } <- Array.uncons path
100 t <- parsePathPiece @t h
101 serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
103else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
104 serveRoute { path, verb } = do
105 assert $ verb == "GET"
106 assert $ path == []
107 pure $ \(Nt nt) handler _req -> do
108 resp <- nt handler
109 pure $ toResponse resp
111else instance ServeRoute (POST Unit Unit) (m Unit) m where
112 serveRoute { path, verb } = do
113 assert $ verb == "POST"
114 assert $ path == []
115 pure $ \(Nt nt) handler _req -> do
116 nt handler
117 pure $ ok
118else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
119 serveRoute { path, verb } = do
120 assert $ verb == "POST"
121 assert $ path == []
122 pure $ \(Nt nt) handler _req -> do
123 resp <- nt handler
124 pure $ toResponse resp
125else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
126 serveRoute { path, verb } = do
127 assert $ verb == "POST"
128 assert $ path == []
129 pure $ \(Nt nt) handler req -> do
130 liftAff (fromRequest req) >>= case _ of
131 Nothing -> pure $ badRequest
132 Just r -> do
133 nt $ handler r
134 pure $ ok
135else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
136 serveRoute { path, verb } = do
137 assert $ verb == "POST"
138 assert $ path == []
139 pure $ \(Nt nt) handler req -> do
140 liftAff (fromRequest req) >>= case _ of
141 Nothing -> pure $ badRequest
142 Just r -> do
143 resp <- nt $ handler r
144 pure $ toResponse resp
146else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
147 serveRoute { path, verb } = do
148 assert $ verb == "DELETE"
149 assert $ path == []
150 pure $ \(Nt nt) handler _req -> do
151 nt handler
152 pure $ ok
153else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
154 serveRoute { path, verb } = do
155 assert $ verb == "DELETE"
156 assert $ path == []
157 pure $ \(Nt nt) handler _req -> do
158 resp <- nt handler
159 pure $ toResponse resp
160else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
161 serveRoute { path, verb } = do
162 assert $ verb == "DELETE"
163 assert $ path == []
164 pure $ \(Nt nt) handler req -> do
165 liftAff (fromRequest req) >>= case _ of
166 Nothing -> pure $ badRequest
167 Just r -> do
168 nt $ handler r
169 pure $ ok
170else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
171 serveRoute { path, verb } = do
172 assert $ verb == "DELETE"
173 assert $ path == []
174 pure $ \(Nt nt) handler req -> do
175 liftAff (fromRequest req) >>= case _ of
176 Nothing -> pure $ badRequest
177 Just r -> do
178 resp <- nt $ handler r
179 pure $ toResponse resp
181else instance ServeRoute (PUT Unit Unit) (m Unit) m where
182 serveRoute { path, verb } = do
183 assert $ verb == "PUT"
184 assert $ path == []
185 pure $ \(Nt nt) handler _req -> do
186 nt handler
187 pure $ ok
188else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where
189 serveRoute { path, verb } = do
190 assert $ verb == "PUT"
191 assert $ path == []
192 pure $ \(Nt nt) handler _req -> do
193 resp <- nt handler
194 pure $ toResponse resp
195else instance (FromRequest req) => ServeRoute (PUT resp Unit) (req -> m Unit) m where
196 serveRoute { path, verb } = do
197 assert $ verb == "PUT"
198 assert $ path == []
199 pure $ \(Nt nt) handler req -> do
200 liftAff (fromRequest req) >>= case _ of
201 Nothing -> pure $ badRequest
202 Just r -> do
203 nt $ handler r
204 pure $ ok
205else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT req resp) (req -> m resp) m where
206 serveRoute { path, verb } = do
207 assert $ verb == "PUT"
208 assert $ path == []
209 pure $ \(Nt nt) handler req -> do
210 liftAff (fromRequest req) >>= case _ of
211 Nothing -> pure $ badRequest
212 Just r -> do
213 resp <- nt $ handler r
214 pure $ toResponse resp
216else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
217 serveRoute { path, verb } = do
218 assert $ verb == "PATCH"
219 assert $ path == []
220 pure $ \(Nt nt) handler _req -> do
221 nt handler
222 pure $ ok
223else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
224 serveRoute { path, verb } = do
225 assert $ verb == "PATCH"
226 assert $ path == []
227 pure $ \(Nt nt) handler _req -> do
228 resp <- nt handler
229 pure $ toResponse resp
230else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where
231 serveRoute { path, verb } = do
232 assert $ verb == "PATCH"
233 assert $ path == []
234 pure $ \(Nt nt) handler req -> do
235 liftAff (fromRequest req) >>= case _ of
236 Nothing -> pure $ badRequest
237 Just r -> do
238 nt $ handler r
239 pure $ ok
240else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where
241 serveRoute { path, verb } = do
242 assert $ verb == "PATCH"
243 assert $ path == []
244 pure $ \(Nt nt) handler req -> do
245 liftAff (fromRequest req) >>= case _ of
246 Nothing -> pure $ badRequest
247 Just r -> do
248 resp <- nt $ handler r
249 pure $ toResponse resp
251else instance
252 ( ServeAPI routes list handlers m
253 , RowToList routes list
254 ) =>
255 ServeRoute routes (Record handlers) m where
256 serveRoute route = pure $ \nt handlers req ->
257 serveAPI @routes @list nt handlers route req
259class ServeQuery :: Row Type -> RowList Type -> Constraint
260class ServeQuery row list | list -> row where
261 serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
263instance ServeQuery () RowList.Nil where
264 serveQuery _ = Just $ identity
266instance
267 ( ParsePathPiece t
268 , ServeQuery tail rest
269 , IsSymbol field
270 , Row.Cons field (Array t) tail row
271 , Row.Lacks field tail
272 ) =>
273 ServeQuery row (RowList.Cons field (Array t) rest) where
274 serveQuery m = do
275 r <- serveQuery @tail @rest m
276 case Map.lookup (reflectSymbol @field Proxy) m of
277 Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
278 Just a -> do
279 v <- parsePathPiece @t `traverse` a
280 pure $ Builder.insert (Proxy @field) v <<< r
282else instance
283 ( ParsePathPiece t
284 , ServeQuery tail rest
285 , IsSymbol field
286 , Row.Cons field (Maybe t) tail row
287 , Row.Lacks field tail
288 ) =>
289 ServeQuery row (RowList.Cons field (Maybe t) rest) where
290 serveQuery m = do
291 r <- serveQuery @tail @rest m
292 case Map.lookup (reflectSymbol @field Proxy) m of
293 Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
294 Just a -> do
295 { head, tail } <- Array.uncons a
296 assert $ tail == []
297 v <- parsePathPiece @t head
298 pure $ Builder.insert (Proxy @field) (Just v) <<< r
300else instance
301 ( ParsePathPiece t
302 , ServeQuery tail rest
303 , IsSymbol field
304 , Row.Cons field t tail row
305 , Row.Lacks field tail
306 ) =>
307 ServeQuery row (RowList.Cons field t rest) where
308 serveQuery m = do
309 { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
310 assert $ tail == []
311 v <- parsePathPiece @t head
312 r <- serveQuery @tail @rest m
313 pure $ Builder.insert (Proxy @field) v <<< r
315class ToResponse r where
316 toResponse :: r -> Response
318instance EncodeJson (Record row) => ToResponse (Record row) where
319 toResponse rec = Response.json (encodeJson rec) { status: 200, statusText: "OK", headers: [] }
321instance ToResponse Response where
322 toResponse resp = resp
324class FromRequest r where
325 fromRequest :: Request -> Aff (Maybe r)
327instance DecodeJson (Record row) => FromRequest (Record row) where
328 fromRequest req = Request.json req <#> \j -> case decodeJson j of
329 Right r -> Just r
330 Left _ -> Nothing
332instance FromRequest Request where
333 fromRequest req = pure $ Just req
335class ParsePathPiece t where
336 parsePathPiece :: String -> Maybe t
338instance ParsePathPiece String where
339 parsePathPiece = Just
341instance ParsePathPiece Int where
342 parsePathPiece = Int.fromString
344instance ParsePathPiece Number where
345 parsePathPiece = Number.fromString
347instance ParsePathPiece Boolean where
348 parsePathPiece s = case String.toLower s of
349 "true" -> Just true
350 "1" -> Just true
351 "false" -> Just false
352 "0" -> Just false
353 _ -> Nothing
355assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
356assert true = pure unit
357assert false = empty
359class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
360class ServeAPI row list handlers m | row -> handlers, handlers -> m where
361 serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
363instance ServeAPI row RowList.Nil () m where
364 serveAPI _ _ _ _ = pure notFound
366instance
367 ( ServeRoute t handler m
368 , Row.Cons field t tail row
369 , ServeAPI row rest restHandlers m
370 , IsSymbol field
371 , Row.Cons field handler restHandlers handlers
372 , Row.Lacks field restHandlers
373 ) =>
374 ServeAPI row (RowList.Cons field t rest) handlers m where
375 serveAPI nt handlers route req =
376 case serveRoute @t route of
377 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
378 Just f -> f nt (Record.get (Proxy @field) handlers) req
380notFound :: Response
381notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
383internalServerError :: Response
384internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }
386badRequest :: Response
387badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
389ok :: Response
390ok = Response.string "" { status: 200, statusText: "OK", headers: [] }
392-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
393-- | instead you can just pass `identity` as the first argument.
394run
395 :: forall @row list handlers m
396 . RowToList row list
397 => ServeAPI row list handlers m
398 => (forall x. m x -> Server x)
399 -> Record handlers
400 -> Request
401 -> Aff Response
402run nt handlers req = do
403 res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
404 pure case res of
405 Left resp -> resp
406 Right resp -> resp