git.iko.soy/purestack-dev/purescript-purestack-server
on c0ddf54 help sign in
purestack-dev/purescript-purestack-server/src/PureStack/Server.purs
398 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
251class ServeQuery :: Row Type -> RowList Type -> Constraint
252class ServeQuery row list | list -> row where
253 serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
255instance ServeQuery () RowList.Nil where
256 serveQuery _ = Just $ identity
258instance
259 ( ParsePathPiece t
260 , ServeQuery tail rest
261 , IsSymbol field
262 , Row.Cons field (Array t) tail row
263 , Row.Lacks field tail
264 ) =>
265 ServeQuery row (RowList.Cons field (Array t) rest) where
266 serveQuery m = do
267 r <- serveQuery @tail @rest m
268 case Map.lookup (reflectSymbol @field Proxy) m of
269 Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
270 Just a -> do
271 v <- parsePathPiece @t `traverse` a
272 pure $ Builder.insert (Proxy @field) v <<< r
274else instance
275 ( ParsePathPiece t
276 , ServeQuery tail rest
277 , IsSymbol field
278 , Row.Cons field (Maybe t) tail row
279 , Row.Lacks field tail
280 ) =>
281 ServeQuery row (RowList.Cons field (Maybe t) rest) where
282 serveQuery m = do
283 r <- serveQuery @tail @rest m
284 case Map.lookup (reflectSymbol @field Proxy) m of
285 Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
286 Just a -> do
287 { head, tail } <- Array.uncons a
288 assert $ tail == []
289 v <- parsePathPiece @t head
290 pure $ Builder.insert (Proxy @field) (Just v) <<< r
292else instance
293 ( ParsePathPiece t
294 , ServeQuery tail rest
295 , IsSymbol field
296 , Row.Cons field t tail row
297 , Row.Lacks field tail
298 ) =>
299 ServeQuery row (RowList.Cons field t rest) where
300 serveQuery m = do
301 { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
302 assert $ tail == []
303 v <- parsePathPiece @t head
304 r <- serveQuery @tail @rest m
305 pure $ Builder.insert (Proxy @field) v <<< r
307class ToResponse r where
308 toResponse :: r -> Response
310instance EncodeJson (Record row) => ToResponse (Record row) where
311 toResponse rec = Response.json (encodeJson rec) { status: 200, statusText: "OK", headers: [] }
313instance ToResponse Response where
314 toResponse resp = resp
316class FromRequest r where
317 fromRequest :: Request -> Aff (Maybe r)
319instance DecodeJson (Record row) => FromRequest (Record row) where
320 fromRequest req = Request.json req <#> \j -> case decodeJson j of
321 Right r -> Just r
322 Left _ -> Nothing
324instance FromRequest Request where
325 fromRequest req = pure $ Just req
327class ParsePathPiece t where
328 parsePathPiece :: String -> Maybe t
330instance ParsePathPiece String where
331 parsePathPiece = Just
333instance ParsePathPiece Int where
334 parsePathPiece = Int.fromString
336instance ParsePathPiece Number where
337 parsePathPiece = Number.fromString
339instance ParsePathPiece Boolean where
340 parsePathPiece s = case String.toLower s of
341 "true" -> Just true
342 "1" -> Just true
343 "false" -> Just false
344 "0" -> Just false
345 _ -> Nothing
347assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
348assert true = pure unit
349assert false = empty
351class ServeAPI :: Row Type -> RowList Type -> Row Type -> (Type -> Type) -> Constraint
352class ServeAPI row list handlers m | row -> handlers, handlers -> m where
353 serveAPI :: Nt m -> Record handlers -> Route -> Request -> Server Response
355instance ServeAPI row RowList.Nil () m where
356 serveAPI _ _ _ _ = pure notFound
358instance
359 ( ServeRoute t handler m
360 , Row.Cons field t tail row
361 , ServeAPI row rest restHandlers m
362 , IsSymbol field
363 , Row.Cons field handler restHandlers handlers
364 , Row.Lacks field restHandlers
365 ) =>
366 ServeAPI row (RowList.Cons field t rest) handlers m where
367 serveAPI nt handlers route req =
368 case serveRoute @t route of
369 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
370 Just f -> f nt (Record.get (Proxy @field) handlers) req
372notFound :: Response
373notFound = Response.string "" { status: 404, statusText: "Not Found", headers: [] }
375internalServerError :: Response
376internalServerError = Response.string "" { status: 500, statusText: "Internal Server Error", headers: [] }
378badRequest :: Response
379badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
381ok :: Response
382ok = Response.string "" { status: 200, statusText: "OK", headers: [] }
384-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
385-- | instead you can just pass `identity` as the first argument.
386run
387 :: forall @row list handlers m
388 . RowToList row list
389 => ServeAPI row list handlers m
390 => (forall x. m x -> Server x)
391 -> Record handlers
392 -> Request
393 -> Aff Response
394run nt handlers req = do
395 res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
396 pure case res of
397 Left resp -> resp
398 Right resp -> resp