@@ -1,9 +1,23 @@
11module PureStack.Server
22 ( Server
3− , serve
3+ , class ToResponse
4+ , toResponse
5+ , class FromRequest
6+ , fromRequest
7+ , run
8+ , notFound
9+ , internalServerError
10+ , badRequest
11+ -------------------------------------------------------------------------------------------------
412 , class ServeAPI
513 , serveAPI
614 , Nt(..)
15+ , class ServeRoute
16+ , serveRoute
17+ , class ServeQuery
18+ , serveQuery
19+ , class ParsePathPiece
20+ , parsePathPiece
721 ) where
822
923import Prelude
@@ -14,35 +28,46 @@ import Bun.Request as Request
1428import Bun.Response (Response)
1529import Bun.Response as Response
1630import Control.Alternative (class Plus, empty)
17−import Control.Monad.Except (ExceptT, runExceptT, throwError)
31+import Control.Monad.Except (ExceptT, runExceptT)
1832import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
1933import Data.Array as Array
2034import Data.Either (Either(..))
35+import Data.Int as Int
36+import Data.Map (Map)
37+import Data.Map as Map
2138import Data.Maybe (Maybe(..))
39+import Data.Number as Number
2240import Data.Symbol (class IsSymbol, reflectSymbol)
41+import Data.Traversable (traverse)
2342import Data.URL as URL
24−import Effect (Effect)
2543import Effect.Aff (Aff)
2644import Effect.Aff.Class (liftAff)
27−import Prim.Row (class Lacks)
2845import Prim.Row as Row
2946import Prim.RowList (class RowToList, RowList)
3047import Prim.RowList as RowList
3148import Record as Record
49+import Record.Builder (Builder)
50+import Record.Builder as Builder
3251import Type.Proxy (Proxy(..))
3352
34−type Route = { path :: Array String, verb :: String }
53+type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }
3554
3655routeFromRequest :: Request -> Route
3756routeFromRequest req =
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− }
57+ let
58+ url = URL.fromString $ Request.url req
59+ in
60+ { verb: Request.method req
61+ , path: case url of
62+ Nothing -> []
63+ Just u -> case URL.path u of
64+ URL.PathEmpty -> []
65+ URL.PathAbsolute p -> p
66+ URL.PathRelative p -> p
67+ , query: case url of
68+ Nothing -> Map.empty
69+ Just u -> URL.query u
70+ }
4671
4772type Server a = ExceptT Response Aff a
4873
@@ -53,16 +78,26 @@ class ServeRoute route handler m | route -> handler, handler -> m where
5378 serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)
5479
5580instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where
56− serveRoute { path, verb } = do
81+ serveRoute route@{ path } = do
5782 { head: h, tail } <- Array.uncons path
5883 assert $ h == (reflectSymbol @path Proxy)
59− serveRoute @rest { path: tail, verb: verb }
84+ serveRoute @rest route { path = tail }
85+
86+else instance
87+ ( ServeRoute rest handler m
88+ , ServeQuery row list
89+ , RowToList row list
90+ ) =>
91+ ServeRoute (Record row / rest) (Record row -> handler) m where
92+ serveRoute route@{ query } = do
93+ builder <- serveQuery @row @list query
94+ serveRoute @rest route <#> (\f nt handler req -> f nt (handler $ Builder.buildFromScratch builder) req)
6095
6196else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where
62− serveRoute { path, verb } = do
97+ serveRoute route@{ path } = do
6398 { head: h, tail } <- Array.uncons path
6499 t <- parsePathPiece @t h
65− serveRoute @rest { path: tail, verb } <#> (\f nt handler req -> f nt (handler t) req)
100+ serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
66101
67102else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
68103 serveRoute { path, verb } = do
@@ -91,6 +126,62 @@ else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (
91126 resp <- nt $ handler r
92127 pure $ toResponse resp
93128
129+class ServeQuery :: Row Type -> RowList Type -> Constraint
130+class ServeQuery row list | list -> row where
131+ serveQuery :: Map String (Array String) -> Maybe (Builder (Record ()) (Record row))
132+
133+instance ServeQuery () RowList.Nil where
134+ serveQuery _ = Just $ identity
135+
136+instance
137+ ( ParsePathPiece t
138+ , ServeQuery tail rest
139+ , IsSymbol field
140+ , Row.Cons field (Array t) tail row
141+ , Row.Lacks field tail
142+ ) =>
143+ ServeQuery row (RowList.Cons field (Array t) rest) where
144+ serveQuery m = do
145+ r <- serveQuery @tail @rest m
146+ case Map.lookup (reflectSymbol @field Proxy) m of
147+ Nothing -> pure $ Builder.insert (Proxy @field) [] <<< r
148+ Just a -> do
149+ v <- parsePathPiece @t `traverse` a
150+ pure $ Builder.insert (Proxy @field) v <<< r
151+
152+else instance
153+ ( ParsePathPiece t
154+ , ServeQuery tail rest
155+ , IsSymbol field
156+ , Row.Cons field (Maybe t) tail row
157+ , Row.Lacks field tail
158+ ) =>
159+ ServeQuery row (RowList.Cons field (Maybe t) rest) where
160+ serveQuery m = do
161+ r <- serveQuery @tail @rest m
162+ case Map.lookup (reflectSymbol @field Proxy) m of
163+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
164+ Just a -> do
165+ { head, tail } <- Array.uncons a
166+ assert $ tail == []
167+ v <- parsePathPiece @t head
168+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
169+
170+else instance
171+ ( ParsePathPiece t
172+ , ServeQuery tail rest
173+ , IsSymbol field
174+ , Row.Cons field t tail row
175+ , Row.Lacks field tail
176+ ) =>
177+ ServeQuery row (RowList.Cons field t rest) where
178+ serveQuery m = do
179+ { head, tail } <- Map.lookup (reflectSymbol @field Proxy) m >>= Array.uncons
180+ assert $ tail == []
181+ v <- parsePathPiece @t head
182+ r <- serveQuery @tail @rest m
183+ pure $ Builder.insert (Proxy @field) v <<< r
184+
94185class ToResponse r where
95186 toResponse :: r -> Response
96187
@@ -114,6 +205,15 @@ instance FromRequest Request where
114205class ParsePathPiece t where
115206 parsePathPiece :: String -> Maybe t
116207
208+instance ParsePathPiece String where
209+ parsePathPiece = Just
210+
211+instance ParsePathPiece Int where
212+ parsePathPiece = Int.fromString
213+
214+instance ParsePathPiece Number where
215+ parsePathPiece = Number.fromString
216+
117217assert :: forall m. Applicative m => Plus m => Boolean -> m Unit
118218assert true = pure unit
119219assert false = empty
@@ -134,8 +234,8 @@ instance
134234 , Row.Lacks field restHandlers
135235 ) =>
136236 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
237+ serveAPI nt handlers route req =
238+ case serveRoute @t route of
139239 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req
140240 Just f -> f nt (Record.get (Proxy @field) handlers) req
141241
@@ -148,7 +248,9 @@ internalServerError = Response.string "" { status: 500, statusText: "Internal Se
148248badRequest :: Response
149249badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }
150250
151−serve
251+-- | The first argument is used to run an arbitrary monad in handlers. To use the 'Server' monad
252+-- | instead you can just pass `identity` as the first argument.
253+run
152254 :: forall @row list handlers m
153255 . RowToList row list
154256 => ServeAPI row list handlers m
@@ -156,61 +258,8 @@ serve
156258 -> Record handlers
157259 -> Request
158260 -> Aff Response
159−serve nt handlers req = do
261+run nt handlers req = do
160262 res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
161263 pure case res of
162264 Left resp -> resp
163265 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