2a5d0f5 · purestack-dev/purescript-purestack-server

git.iko.soy/purestack-dev/purescript-purestack-server

on master help sign in

got query records working

2a5d0f5iko1 year ago

spago.dhall+3−2

compare with master

unifiedsplit

@@ -8,15 +8,16 @@

8 , "control"

9 , "effect"

10 , "either"

11+ , "foldable-traversable"

11 , "maybe"

12 , "maybe"

13+ , "ordered-collections"

12 , "prelude"

14 , "prelude"

13 , "record"

15 , "record"

14 , "run"

16 , "run"

17+ , "transformers"

15 , "tuples"

18 , "tuples"

16 , "typelevel-prelude"

19 , "typelevel-prelude"

17− , "unsafe-coerce"

18 , "url-immutable"

20 , "url-immutable"

19− , "variant"

20 ]

21 ]

21, packages = ./packages.dhall

22, packages = ./packages.dhall

22, sources = [ "src/**/*.purs", "test/**/*.purs" ]

23, sources = [ "src/**/*.purs", "test/**/*.purs" ]

src/Bun/Server.js+1−1

@@ -1,4 +1,4 @@

1−export function serve(f) {

1+export function serve_(f) {

2 return function() {

3 return Bun.serve({

4 fetch(req) {

src/Bun/Server.purs+7−1

@@ -4,6 +4,12 @@ import Prelude

5import Bun.Request (Request)

6import Bun.Response (Response)

7+import Control.Promise (Promise)

8+import Control.Promise as Promise

7import Effect (Effect)

9import Effect (Effect)

10+import Effect.Aff (Aff)

12+foreign import serve_ :: (Request -> Effect (Promise Response)) -> Effect Unit

13+

9−foreign import serve :: (Request -> Effect Response) -> Effect Unit

14+serve :: (Request -> Aff Response) -> Effect Unit

15+serve f = serve_ (\req -> Promise.fromAff (f req))

src/Main.purs+9−5

@@ -3,23 +3,27 @@ module Main where

3import Prelude

5import Bun.Server as Bun

6+import Data.Maybe (Maybe)

6import Effect (Effect)

7import Effect (Effect)

7import Effect.Aff (Aff)

8import Effect.Aff (Aff)

8import Effect.Console (log)

9import Effect.Console (log)

9import PureStack.Route (type (/), GET, POST)

10import PureStack.Route (type (/), GET, POST)

10import PureStack.Route as Router

11import PureStack.Route as Router

12+import PureStack.Server as Server

11import Run (AFF, Run(..), runBaseAff)

13import Run (AFF, Run(..), runBaseAff)

12import Type.Row (type (+))

14import Type.Row (type (+))

16+type Foo = { a :: String, b :: Maybe Int, c :: Array Number }

17+

14type API =

18type API =

15− ( foo :: "foo" / "bar" / "foo" / GET { a :: Int, b :: Number }

19+ ( foo :: "foo" / "bar" / Foo / GET { a :: Int, b :: Number, c :: Foo }

16 , bar :: "foo" / "qux" / POST Unit { a :: Int }

20 , bar :: "foo" / "qux" / POST Unit { a :: Int }

17 )

21 )

19−x :: { foo :: Run (AFF + ()) { a :: Int, b :: Number }, bar :: Run (AFF + ()) { a :: Int } }

20−x = { foo: pure { a: 1, b: 1.0 }, bar: pure { a: 8 } }

21−

22main :: Effect Unit

23main :: Effect Unit

23main = do

24main = do

24 log "🍝"

25 log "🍝"

25−-- Bun.serve $ Router.run @API

26+ Bun.serve $ Server.run @API identity

27+ { foo: \x -> pure { a: 1, b: 1.0, c: x }

28+ , bar: pure { a: 8 }

29+ }

src/PureStack/Server.purs+123−74

@@ -1,9 +1,23 @@

1module PureStack.Server

2 ( Server

3− , serve

3+ , class ToResponse

4+ , toResponse

5+ , class FromRequest

6+ , fromRequest

7+ , run

8+ , notFound

9+ , internalServerError

10+ , badRequest

11+ -------------------------------------------------------------------------------------------------

4 , class ServeAPI

12 , class ServeAPI

5 , serveAPI

13 , serveAPI

6 , Nt(..)

14 , Nt(..)

15+ , class ServeRoute

16+ , serveRoute

17+ , class ServeQuery

18+ , serveQuery

19+ , class ParsePathPiece

20+ , parsePathPiece

7 ) where

21 ) where

9import Prelude

23import Prelude

@@ -14,35 +28,46 @@ import Bun.Request as Request

14import Bun.Response (Response)

28import Bun.Response (Response)

15import Bun.Response as Response

29import Bun.Response as Response

16import Control.Alternative (class Plus, empty)

30import Control.Alternative (class Plus, empty)

17−import Control.Monad.Except (ExceptT, runExceptT, throwError)

31+import Control.Monad.Except (ExceptT, runExceptT)

18import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)

32import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)

19import Data.Array as Array

33import Data.Array as Array

20import Data.Either (Either(..))

34import Data.Either (Either(..))

35+import Data.Int as Int

36+import Data.Map (Map)

37+import Data.Map as Map

21import Data.Maybe (Maybe(..))

38import Data.Maybe (Maybe(..))

39+import Data.Number as Number

22import Data.Symbol (class IsSymbol, reflectSymbol)

40import Data.Symbol (class IsSymbol, reflectSymbol)

41+import Data.Traversable (traverse)

23import Data.URL as URL

42import Data.URL as URL

24−import Effect (Effect)

25import Effect.Aff (Aff)

43import Effect.Aff (Aff)

26import Effect.Aff.Class (liftAff)

44import Effect.Aff.Class (liftAff)

27−import Prim.Row (class Lacks)

28import Prim.Row as Row

45import Prim.Row as Row

29import Prim.RowList (class RowToList, RowList)

46import Prim.RowList (class RowToList, RowList)

30import Prim.RowList as RowList

47import Prim.RowList as RowList

31import Record as Record

48import Record as Record

49+import Record.Builder (Builder)

50+import Record.Builder as Builder

32import Type.Proxy (Proxy(..))

51import Type.Proxy (Proxy(..))

34−type Route = { path :: Array String, verb :: String }

53+type Route = { path :: Array String, verb :: String, query :: Map String (Array String) }

36routeFromRequest :: Request -> Route

55routeFromRequest :: Request -> Route

37routeFromRequest req =

56routeFromRequest req =

57+ let

58+ url = URL.fromString $ Request.url req

59+ in

38− { verb: Request.method req

60+ { verb: Request.method req

39− , path: case URL.fromString (Request.url req) of

61+ , path: case url of

40− Nothing -> []

62+ Nothing -> []

41− Just url -> case URL.path url of

63+ Just u -> case URL.path u of

42− URL.PathEmpty -> []

64+ URL.PathEmpty -> []

43− URL.PathAbsolute p -> p

65+ URL.PathAbsolute p -> p

44− URL.PathRelative p -> p

66+ URL.PathRelative p -> p

67+ , query: case url of

68+ Nothing -> Map.empty

69+ Just u -> URL.query u

45− }

70+ }

47type Server a = ExceptT Response Aff a

72type Server a = ExceptT Response Aff a

@@ -53,16 +78,26 @@ class ServeRoute route handler m | route -> handler, handler -> m where

53 serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)

78 serveRoute :: Route -> Maybe (Nt m -> handler -> Request -> Server Response)

55instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where

80instance (ServeRoute rest handler m, IsSymbol path) => ServeRoute (path / rest) handler m where

56− serveRoute { path, verb } = do

81+ serveRoute route@{ path } = do

57 { head: h, tail } <- Array.uncons path

82 { head: h, tail } <- Array.uncons path

58 assert $ h == (reflectSymbol @path Proxy)

83 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)

61else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where

96else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / rest) (t -> handler) m where

62− serveRoute { path, verb } = do

97+ serveRoute route@{ path } = do

63 { head: h, tail } <- Array.uncons path

98 { head: h, tail } <- Array.uncons path

64 t <- parsePathPiece @t h

99 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)

101

67else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where

102else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where

68 serveRoute { path, verb } = do

103 serveRoute { path, verb } = do

@@ -91,6 +126,62 @@ else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (

91 resp <- nt $ handler r

126 resp <- nt $ handler r

92 pure $ toResponse resp

127 pure $ toResponse resp

128

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+

94class ToResponse r where

185class ToResponse r where

95 toResponse :: r -> Response

186 toResponse :: r -> Response

187

@@ -114,6 +205,15 @@ instance FromRequest Request where

114class ParsePathPiece t where

205class ParsePathPiece t where

115 parsePathPiece :: String -> Maybe t

206 parsePathPiece :: String -> Maybe t

116

207

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+

117assert :: forall m. Applicative m => Plus m => Boolean -> m Unit

217assert :: forall m. Applicative m => Plus m => Boolean -> m Unit

118assert true = pure unit

218assert true = pure unit

119assert false = empty

219assert false = empty

@@ -134,8 +234,8 @@ instance

134 , Row.Lacks field restHandlers

234 , Row.Lacks field restHandlers

135 ) =>

235 ) =>

136 ServeAPI row (RowList.Cons field t rest) handlers m where

236 ServeAPI row (RowList.Cons field t rest) handlers m where

137− serveAPI nt handlers route@{ path, verb } req =

237+ serveAPI nt handlers route req =

138− case serveRoute @t { path, verb } of

238+ case serveRoute @t route of

139 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req

239 Nothing -> serveAPI @row @rest @restHandlers nt (Record.delete (Proxy @field) handlers) route req

140 Just f -> f nt (Record.get (Proxy @field) handlers) req

240 Just f -> f nt (Record.get (Proxy @field) handlers) req

141

241

@@ -148,7 +248,9 @@ internalServerError = Response.string "" { status: 500, statusText: "Internal Se

148badRequest :: Response

248badRequest :: Response

149badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }

249badRequest = Response.string "" { status: 400, statusText: "Bad Request", headers: [] }

150

250

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

152 :: forall @row list handlers m

254 :: forall @row list handlers m

153 . RowToList row list

255 . RowToList row list

154 => ServeAPI row list handlers m

256 => ServeAPI row list handlers m

@@ -156,61 +258,8 @@ serve

156 -> Record handlers

258 -> Record handlers

157 -> Request

259 -> Request

158 -> Aff Response

260 -> Aff Response

159−serve nt handlers req = do

261+run nt handlers req = do

160 res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req

262 res <- runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req

161 pure case res of

263 pure case res of

162 Left resp -> resp

264 Left resp -> resp

163 Right resp -> resp

265 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