git.iko.soy/purestack-dev/purescript-purestack-server
on a6a87a1 help sign in
purestack-dev/purescript-purestack-server/src/PureStack/Server.purs
419 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 ) where
25import Prelude
26import PureStack.Route
28import Bun.Request (Request)
29import Bun.Request as Request
30import Bun.Response as Bun.Response
31import Control.Alternative (class Plus, empty)
32import Control.Monad.Except (ExceptT, runExceptT)
33import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)
34import Data.Array as Array
35import Data.Either (Either(..), either)
36import Data.Int as Int
37import Data.Map (Map)
38import Data.Map as Map
39import Data.Maybe (Maybe(..))
40import Data.Number as Number
41import Data.String as String
42import Data.Symbol (class IsSymbol, reflectSymbol)
43import Data.Traversable (traverse)
44import Data.URL as URL
45import Effect.Aff (Aff)
46import Effect.Aff.Class (liftAff)
47import Foreign.Object (Object)
48import Foreign.Object as Object
49import Prim.Row as Row
50import Prim.RowList (class RowToList, RowList)
51import Prim.RowList as RowList
52import Record as Record
53import Record.Builder (Builder)
54import Record.Builder as Builder
55import Type.Proxy (Proxy(..))
57type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
59routeFromRequest :: Request -> Route
60routeFromRequest req =
61 let
62 url = URL.fromString $ Request.url req
63 in
64 { verb: Request.method req
65 , path: case url of
66 Nothing -> []
67 Just u -> case URL.path u of
68 URL.PathEmpty -> []
69 URL.PathAbsolute p -> p
70 URL.PathRelative p -> p
71 , query: case url of
72 Nothing -> Map.empty
73 Just u -> URL.query u
74 }
76type Server a = ExceptT Response Aff a
78newtype Nt m = Nt (forall x. m x -> Server x)
80class ServeRoute :: forall k. k -> Type -> (Type -> Type) -> Constraint
81class ServeRoute route handler m | route -> handler, handler -> m where
82 serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
84instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
85 serveRoute route@{ path } = do
86 { head: h, tail } <- Array.uncons path
87 assert $ h == (reflectSymbol @path Proxy)
88 serveRoute @rest route { path = tail }
90else instance
91 ( ServeRoute rest handler m
92 , ServeQuery row list
93 , RowToList row list
94 ) =>
95 ServeRoute (Record row / rest) (Record row -> handler) m where
96 serveRoute route@{ query } = do
97 builder <- serveQuery @row @list query
98 serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
100else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
101 serveRoute route@{ path } = do
102 { head: h, tail } <- Array.uncons path
103 t <- parsePathPiece @t h
104 serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
106else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
107 serveRoute { path, verb } = do
108 assert $ verb == "GET"
109 assert $ path == []
110 pure $ \(Nt nt) handler _req -> do
111 resp <- nt handler
112 pure $ toResponse resp
114else instance ServeRoute (POST Unit Unit) (m Unit) m where
115 serveRoute { path, verb } = do
116 assert $ verb == "POST"
117 assert $ path == []
118 pure $ \(Nt nt) handler _req -> do
119 nt handler
120 pure $ ok
121else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
122 serveRoute { path, verb } = do
123 assert $ verb == "POST"
124 assert $ path == []
125 pure $ \(Nt nt) handler _req -> do
126 resp <- nt handler
127 pure $ toResponse resp
128else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
129 serveRoute { path, verb } = do
130 assert $ verb == "POST"
131 assert $ path == []
132 pure $ \(Nt nt) handler req -> do
133 liftAff (fromRequest req) >>= case _ of
134 Nothing -> pure $ badRequest
135 Just r -> do
136 nt $ handler r
137 pure $ ok
138else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
139 serveRoute { path, verb } = do
140 assert $ verb == "POST"
141 assert $ path == []
142 pure $ \(Nt nt) handler req -> do
143 liftAff (fromRequest req) >>= case _ of
144 Nothing -> pure $ badRequest
145 Just r -> do
146 resp <- nt $ handler r
147 pure $ toResponse resp
149else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
150 serveRoute { path, verb } = do
151 assert $ verb == "DELETE"
152 assert $ path == []
153 pure $ \(Nt nt) handler _req -> do
154 nt handler
155 pure $ ok
156else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
157 serveRoute { path, verb } = do
158 assert $ verb == "DELETE"
159 assert $ path == []
160 pure $ \(Nt nt) handler _req -> do
161 resp <- nt handler
162 pure $ toResponse resp
163else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
164 serveRoute { path, verb } = do
165 assert $ verb == "DELETE"
166 assert $ path == []
167 pure $ \(Nt nt) handler req -> do
168 liftAff (fromRequest req) >>= case _ of
169 Nothing -> pure $ badRequest
170 Just r -> do
171 nt $ handler r
172 pure $ ok
173else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
174 serveRoute { path, verb } = do
175 assert $ verb == "DELETE"
176 assert $ path == []
177 pure $ \(Nt nt) handler req -> do
178 liftAff (fromRequest req) >>= case _ of
179 Nothing -> pure $ badRequest
180 Just r -> do
181 resp <- nt $ handler r
182 pure $ toResponse resp
184else instance ServeRoute (PUT Unit Unit) (m Unit) m where
185 serveRoute { path, verb } = do
186 assert $ verb == "PUT"
187 assert $ path == []
188 pure $ \(Nt nt) handler _req -> do
189 nt handler
190 pure $ ok
191else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where
192 serveRoute { path, verb } = do
193 assert $ verb == "PUT"
194 assert $ path == []
195 pure $ \(Nt nt) handler _req -> do
196 resp <- nt handler
197 pure $ toResponse resp
198else instance (FromRequest req) => ServeRoute (PUT resp Unit) (req -> m Unit) m where
199 serveRoute { path, verb } = do
200 assert $ verb == "PUT"
201 assert $ path == []
202 pure $ \(Nt nt) handler req -> do
203 liftAff (fromRequest req) >>= case _ of
204 Nothing -> pure $ badRequest
205 Just r -> do
206 nt $ handler r
207 pure $ ok
208else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT req resp) (req -> m resp) m where
209 serveRoute { path, verb } = do
210 assert $ verb == "PUT"
211 assert $ path == []
212 pure $ \(Nt nt) handler req -> do
213 liftAff (fromRequest req) >>= case _ of
214 Nothing -> pure $ badRequest
215 Just r -> do
216 resp <- nt $ handler r
217 pure $ toResponse resp
219else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
220 serveRoute { path, verb } = do
221 assert $ verb == "PATCH"
222 assert $ path == []
223 pure $ \(Nt nt) handler _req -> do
224 nt handler
225 pure $ ok
226else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
227 serveRoute { path, verb } = do
228 assert $ verb == "PATCH"
229 assert $ path == []
230 pure $ \(Nt nt) handler _req -> do
231 resp <- nt handler
232 pure $ toResponse resp
233else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where
234 serveRoute { path, verb } = do
235 assert $ verb == "PATCH"
236 assert $ path == []
237 pure $ \(Nt nt) handler req -> do
238 liftAff (fromRequest req) >>= case _ of
239 Nothing -> pure $ badRequest
240 Just r -> do
241 nt $ handler r
242 pure $ ok
243else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where
244 serveRoute { path, verb } = do
245 assert $ verb == "PATCH"
246 assert $ path == []
247 pure $ \(Nt nt) handler req -> do
248 liftAff (fromRequest req) >>= case _ of
249 Nothing -> pure $ badRequest
250 Just r -> do
251 resp <- nt $ handler r
252 pure $ toResponse resp
254else instance
255 ( ServeAPI routes list handlers m
256 , RowToList routes list
257 ) =>
258 ServeRoute routes (Record handlers) m where
259 serveRoute route = pure $ \nt handlers req ->
260 serveAPI @routes @list nt handlers route req
262class ServeQuery :: Row Type -> RowList Type -> Constraint
263class ServeQuery row list | list -> row where
264 serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
266instance ServeQuery () RowList.Nil where
267 serveQuery _ = Just $ identity
269instance
270 ( ParsePathPiece t
271 , ServeQuery tail rest
272 , IsSymbol field
273 , Row.Cons field (Array t) tail row
274 , Row.Lacks field tail
275 ) =>
276 ServeQuery row (RowList.Cons field (Array t) rest) where
277 serveQuery m = do
278 r <- serveQuery @tail @rest m
279 case Map.lookup (reflectSymbol @field Proxy) m of
280 Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
281 Just a -> do
282 v <- parsePathPiece @t `traverse` a
283 pure $ Builder.insert (Proxy @field) v <<< r
285else instance
286 ( ParsePathPiece t
287 , ServeQuery tail rest
288 , IsSymbol field
289 , Row.Cons field (Maybe t) tail row
290 , Row.Lacks field tail
291 ) =>
292 ServeQuery row (RowList.Cons field (Maybe t) rest) where
293 serveQuery m = do
294 r <- serveQuery @tail @rest m
295 case Map.lookup (reflectSymbol @field Proxy) m of
296 Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
297 Just a -> do
298 { head, tail } <- Array.uncons a
299 assert $ tail == []
300 v <- parsePathPiece @t head
301 pure $ Builder.insert (Proxy @field) (Just v) <<< r
303else instance
304 ( ParsePathPiece t
305 , ServeQuery tail rest
306 , IsSymbol field
307 , Row.Cons field t tail row
308 , Row.Lacks field tail
309 ) =>
310 ServeQuery row (RowList.Cons field t rest) where
311 serveQuery m = do
312 { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
313 assert $ tail == []
314 v <- parsePathPiece @t head
315 r <- serveQuery @tail @rest m
316 pure $ Builder.insert (Proxy @field) v <<< r
318data ResponseBody
319 = JsonResponseBody Json
320 | EmptyResponseBody
321 | StringResponseBody String
323newtype Response = Response { body :: ResponseBody, status :: Int, statusText :: String, headers :: Object String }
325class ToResponse r where
326 toResponse :: r -> Response
328instance EncodeJson (Record row) => ToResponse (Record row) where
329 toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }
331instance ToResponse Response where
332 toResponse resp = resp
334class FromRequest r where
335 fromRequest :: Request -> Aff (Maybe r)
337instance DecodeJson (Record row) => FromRequest (Record row) where
338 fromRequest req = Request.json req <#> \j -> case decodeJson j of
339 Right r -> Just r
340 Left _ -> Nothing
342instance FromRequest Request where
343 fromRequest req = pure $ Just req
345class ParsePathPiece t where
346 parsePathPiece :: String -> Maybe t
348instance ParsePathPiece String where
349 parsePathPiece = Just
351instance ParsePathPiece Int where
352 parsePathPiece = Int.fromString
354instance ParsePathPiece Number where
355 parsePathPiece = Number.fromString
357instance ParsePathPiece Boolean where
358 parsePathPiece s = case String.toLower s of
359 "true" -> Just true
360 "1" -> Just true
361 "false" -> Just false
362 "0" -> Just false
363 _ -> Nothing
365assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
366assert true = pure unit
367assert false = empty
369class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
370class ServeAPI row list handlers m | row -> handlers, handlers -> m where
371 serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
373instance ServeAPI row RowList.Nil () m where
374 serveAPI _ _ _ _ = pure notFound
376instance
377 ( ServeRoute t handler m
378 , Row.Cons field t tail row
379 , ServeAPI row rest restHandlers m
380 , IsSymbol field
381 , Row.Cons field handler restHandlers handlers
382 , Row.Lacks field restHandlers
383 ) =>
384 ServeAPI row (RowList.Cons field t rest) handlers m where
385 serveAPI nt handlers route req =
386 case serveRoute @t route of
387 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
388 Just f -> f nt (Record.get (Proxy @field) handlers) req
390notFound :: Response
391notFound = Response { body: EmptyResponseBody, status: 404, statusText: "Not Found", headers: Object.empty }
393internalServerError :: Response
394internalServerError = Response { body: EmptyResponseBody, status: 500, statusText: "Internal Server Error", headers: Object.empty }
396badRequest :: Response
397badRequest = Response { body: EmptyResponseBody, status: 400, statusText: "Bad Request", headers: Object.empty }
399ok :: Response
400ok = Response { body: EmptyResponseBody, status: 200, statusText: "OK", headers: Object.empty }
402-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
403-- | instead you can just pass `identity` as the first argument.
404run
405 :: forall @row list handlers m
406 . RowToList row list
407 => ServeAPI row list handlers m
408 => (forall x. m x -> Server x)
409 -> Record handlers
410 -> Request
411 -> Aff Bun.Response.Response
412run nt handlers req = do
413 Response { body, headers, status, statusText } <-
414 map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
415 let opts = { headers, status, statusText }
416 pure $ case body of
417 EmptyResponseBody -> Bun.Response.string "" opts
418 JsonResponseBody json -> Bun.Response.json json opts
419 StringResponseBody string -> Bun.Response.string string opts