c8f9b92 · purestack-dev/todomvc

git.iko.soy/purestack-dev/todomvc

on master help sign in

got backend working

c8f9b92iko1 year ago

.gitignore+2

compare with master

unifiedsplit

@@ -13,3 +13,5 @@ frontend.js

13result

14index.js

15m36

16+backend.js.map

17+frontend.js.map

flake.lock+3−3

@@ -91,11 +91,11 @@

91 "stacklock2nix": "stacklock2nix"

92 },

93 "locked": {

94− "lastModified": 1750766736,

94+ "lastModified": 1751636615,

95− "narHash": "sha256-xSWxfDWjVhRNNyAg7iqv5yEZ+Ofad3YM9gneFO1M0Xg=",

95+ "narHash": "sha256-8svgD2LdlamTqKqCkdf3ROQLckvnXP+vx3M5a57Kl5U=",

96 "owner": "purestack-dev",

97 "repo": "project-m36-rest",

98− "rev": "b137dc5eb0ebfe7071e758b0011cddc18a2eb087",

98+ "rev": "c3a0331d62f7f5c9d90012d533e5713095a5fb4e",

99 "type": "github"

100 },

101 "original": {

flake.nix+2−2

@@ -26,12 +26,12 @@

26 processes = {

27 spago-frontend = {

28 command =

29− "${pkgs.spago}/bin/spago bundle-app --watch --main Frontend --to frontend.js";

29+ "${pkgs.spago}/bin/spago bundle-app --watch --main Frontend --source-maps --to frontend.js";

30 is_tty = true;

31 };

32 spago-backend = {

33 command =

34− "${pkgs.spago}/bin/spago bundle-app --watch --main Backend --to backend.js";

34+ "${pkgs.spago}/bin/spago bundle-app --watch --main Backend --source-maps --to backend.js";

35 is_tty = true;

36 };

37 bun.command = "${pkgs.bun}/bin/bun run --watch backend.js";

spago.dhall+1

@@ -15,6 +15,7 @@

15 , "effect"

16 , "either"

17 , "enums"

18+ , "exceptions"

18 , "ezfetch"

19 , "ezfetch"

19 , "foldable-traversable"

20 , "foldable-traversable"

20 , "foreign"

21 , "foreign"

src/Backend.purs+46−17

@@ -4,30 +4,59 @@ import Prelude

4import PureStack.Route

6import Bun.Server as Bun

7+import Data.Argonaut (class DecodeJson, class EncodeJson)

7−import Data.Maybe (Maybe)

8+import Data.Maybe (Maybe(..))

9+import Data.Newtype (class Newtype, unwrap, wrap)

10+import Data.URL as URL

8import Effect (Effect)

11import Effect (Effect)

12+import Effect.Aff (launchAff_)

13+import Effect.Aff.Class (liftAff)

14+import Effect.Class (liftEffect)

9import Effect.Console (log)

15import Effect.Console (log)

16+import Effect.Exception (throw)

17+import ProjectM36 (class RelVar, define, insert, lit, query, rel, relVar, withTransaction)

18+import ProjectM36 as M36

19+import PureStack.Client (class ToRequest)

20+import PureStack.Server (class FromRequest)

10import PureStack.Server as Server

21import PureStack.Server as Server

12−type Foo = { a :: String, b :: Maybe Int, c :: Array Number }

23+newtype TodoItem = TodoItem { text :: String, done :: Boolean }

24+

25+derive instance Newtype TodoItem _

26+derive newtype instance EncodeJson TodoItem

27+derive newtype instance DecodeJson TodoItem

28+derive newtype instance ToRequest TodoItem

29+derive newtype instance FromRequest TodoItem

30+

31+instance RelVar TodoItem where

32+ relVar = "todo-item"

14type API =

34type API =

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

35+ ( getTodos :: "todos" / GET Unit (Array TodoItem)

16− , bar :: "foo" / Middleware "auth" / "qux" / POST (Headers { foo :: String } Unit) { a :: Int, s :: String }

36+ , createTodo :: "todos" / POST TodoItem Unit

17− , deep ::

18− "deep" /

19− ( something :: "something" / GET Unit (Headers { foo :: String } { a :: String })

20− )

21 )

37 )

23main :: Effect Unit

39main :: Effect Unit

24main = do

40main = do

25− log "🍝"

41+ m36Connection <- case URL.fromString "http://localhost:6543" of

42+ Just url -> pure $ M36.Connection url

43+ Nothing -> throw "Invalid m36 URL"

44+

45+ launchAff_ do

46+ liftEffect $ log "Creating relational variables"

47+ withTransaction m36Connection do

48+ define @TodoItem

49+ liftEffect $ log "Done"

50+

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

51+ liftEffect $ Bun.serve $ Server.run @API identity

27− { handlers:

52+ { handlers:

28− { foo: \x -> pure { a: 1, b: 1.0, c: x }

53+ { getTodos: do

29− , bar: \i (Headers x _) -> pure { a: 8, s: x.foo }

54+ liftAff $ withTransaction m36Connection $ do

30− , deep: { something: pure $ Headers { foo: "foo" } { a: "something" } }

55+ (map <<< map) wrap <$> query $ rel @TodoItem

56+ , createTodo: \todo -> do

57+ liftAff $ withTransaction m36Connection $ do

58+ insert @TodoItem $ lit [ todo ]

59+ pure unit

31− }

60+ }

32− , middlewares: { auth: \req -> pure 1 }

61+ , middlewares: {}

33− }

62+ }

src/Frontend.purs−1

@@ -52,4 +52,3 @@ url = case URL.fromString "localhost" of

53x = client @API url

55−foo = x.deep.something

src/ProjectM36.purs+17−7

@@ -65,11 +65,13 @@ import Data.Set as Set

65import Data.Traversable (traverse)

66import Data.Tuple.Nested (type (/\), (/\))

67import Data.URL (URL, addSegment)

68+import Debug (traceM)

68import Effect.Aff (Aff, bracket, error, throwError)

69import Effect.Aff (Aff, bracket, error, throwError)

69import Effect.Aff.HTTP (Method(..), fetch)

70import Effect.Aff.HTTP (Method(..), fetch)

70import Effect.Aff.HTTP.Request as Request

71import Effect.Aff.HTTP.Request as Request

71import Effect.Aff.HTTP.Response (Response)

72import Effect.Aff.HTTP.Response (Response)

72import Effect.Aff.HTTP.Response as Response

73import Effect.Aff.HTTP.Response as Response

74+import Effect.Class.Console (log)

73import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

75import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

74import Foreign.Object (Object)

76import Foreign.Object (Object)

75import Foreign.Object as Object

77import Foreign.Object as Object

@@ -92,7 +94,7 @@ data Expr

93instance EncodeJson Expr where

95instance EncodeJson Expr where

94 encodeJson = case _ of

96 encodeJson = case _ of

95− Lit l -> l

97+ Lit l -> encodeJson l

96 Join x y -> encodeJson { join: [ x, y ] }

98 Join x y -> encodeJson { join: [ x, y ] }

97 Union x y -> encodeJson { union: [ x, y ] }

99 Union x y -> encodeJson { union: [ x, y ] }

98 Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }

100 Project proj expr -> encodeJson { proj: { proj: proj, expr: expr } }

@@ -116,8 +118,14 @@ class LiteralRelation r fields | r -> fields where

116instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where

118instance (RowList.RowToList fields fields', Relatable fields fields') => LiteralRelation (Array (Record fields)) fields where

117 lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }

119 lit r = Rel $ Lit $ encodeJson { lit: { attrs: attributeTypes @fields @fields', vals: encodeRelation @fields @fields' <$> r } }

118

120

121+else instance

122+ ( Newtype r (Record fields)

123+ , LiteralRelation (Array (Record field)) fields

124+ , RowToList fields fields'

125+ , Relatable fields fields'

126+ ) =>

119−else instance (LiteralRelation (Record fields) fields, Newtype r (Record fields)) => LiteralRelation r fields where

127+ LiteralRelation (Array r) fields where

120− lit = unwrap >>> lit

128+ lit = map unwrap >>> lit

121

129

122rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields

130rel :: forall @rel fields. Newtype rel (Record fields) => RelVar rel => Rel fields

123rel = Rel $ RelationVariable (relVar @rel)

131rel = Rel $ RelationVariable (relVar @rel)

@@ -474,7 +482,7 @@ define

474 => Transaction Unit

482 => Transaction Unit

475define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

483define = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

476 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

484 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

477− { body: Request.json { define: { name: relVar @rel, attrs: Object.fromFoldable (attributeTypes @fields @fields') } } }

485+ { body: Request.json $ jsonToForeign $ encodeJson { define: { name: relVar @rel, attrs: attributeTypes @fields @fields' } } }

478 >>= Response.guardStatusOk

486 >>= Response.guardStatusOk

479 pure unit

487 pure unit

480

488

@@ -485,8 +493,9 @@ insert

485 => Rel fields

493 => Rel fields

486 -> Transaction Unit

494 -> Transaction Unit

487insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

495insert (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

496+ traceM $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } }

488 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

497 fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

489− { body: Request.json { insert: { name: relVar @rel, rel: jsonToForeign (encodeJson r) } } }

498+ { body: Request.json $ jsonToForeign $ encodeJson { insert: { name: relVar @rel, rel: r } } }

490 >>= Response.guardStatusOk

499 >>= Response.guardStatusOk

491 pure unit

500 pure unit

492

501

@@ -498,7 +507,7 @@ query

498 -> Transaction (Array (Record fields))

507 -> Transaction (Array (Record fields))

499query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

508query (Rel r) = Transaction $ ReaderT $ \{ conn: Connection c, sess } -> do

500 resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

509 resp <- fetch POST (c `addSegment` "transaction" `addSegment` sessionString sess)

501− { body: Request.json { query: jsonToForeign (encodeJson r) } }

510+ { body: Request.json $ jsonToForeign $ encodeJson { query: r } }

502 Response.guardStatusOk resp

511 Response.guardStatusOk resp

503 j <- json resp

512 j <- json resp

504 case decodeRelation @fields @fields' j of

513 case decodeRelation @fields @fields' j of

@@ -510,7 +519,8 @@ decodeRelation

510 . BuildRelation fields fields'

519 . BuildRelation fields fields'

511 => Json

520 => Json

512 -> Either JsonDecodeError (Array (Record fields))

521 -> Either JsonDecodeError (Array (Record fields))

522+decodeRelation j = do

513−decodeRelation j = decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')

523+ decodeRelationJson j >>= traverse (decodeRelationFromObject @fields @fields')

514

524

515jsonToForeign :: Json -> Foreign

525jsonToForeign :: Json -> Foreign

516jsonToForeign = unsafeCoerce

526jsonToForeign = unsafeCoerce

src/PureStack/Client.purs+19−5

@@ -22,7 +22,7 @@ import Prelude

22import PureStack.Route

24import Control.Alternative (class Alternative, empty)

25−import Data.Argonaut (class DecodeJson, class EncodeJson, Json, decodeJson, encodeJson)

25+import Data.Argonaut (class DecodeJson, class EncodeJson, Json, JsonDecodeError, decodeJson, encodeJson)

26import Data.ArrayBuffer.Types (ArrayBuffer)

27import Data.Either (Either(..))

28import Data.Map as Map

@@ -225,12 +225,26 @@ instance (ToRequest req, RowToList headers headersList, ToHeaders headers header

225class FromResponse r where

226 fromResponse :: Response -> Aff (Maybe r)

227

228+instance FromResponse Json where

229+ fromResponse resp = map (Just <<< foreignToJson) (Response.json resp)

230+

231+instance DecodeJson x => FromResponse (Array x) where

232+ fromResponse resp = do

233+ fromResponse resp <#> case _ of

234+ Nothing -> Nothing

235+ Just json ->

236+ case decodeJson json of

237+ Right x -> Just x

238+ Left _ -> Nothing

239+

228instance DecodeJson (Record row) => FromResponse (Record row) where

240instance DecodeJson (Record row) => FromResponse (Record row) where

229 fromResponse resp = do

241 fromResponse resp = do

230− json <- map foreignToJson (Response.json resp)

242+ fromResponse resp <#> case _ of

243+ Nothing -> Nothing

244+ Just json ->

231− pure $ case decodeJson json of

245+ case decodeJson json of

232− Right x -> Just x

246+ Right x -> Just x

233− Left _ -> Nothing

247+ Left _ -> Nothing

234

248

235instance FromResponse Unit where

249instance FromResponse Unit where

236 fromResponse _ = pure $ Just unit

250 fromResponse _ = pure $ Just unit

src/PureStack/Server.purs+8−2

@@ -140,7 +140,7 @@ else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth

140 pure $ \(Nt nt) handler _middlewares _req -> do

141 resp <- nt handler

142 pure $ toResponse resp

143−else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) middlewares m where

143+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth req Unit) (req -> m Unit) middlewares m where

144 serveRoute { path, verb } = do

145 assert $ verb == methodName @(meth resp Unit)

146 assert $ path == []

@@ -236,11 +236,17 @@ class ToResponse r where

236 toResponse :: r -> Response

237

238instance EncodeJson (Record row) => ToResponse (Record row) where

239− toResponse rec = Response { body: JsonResponseBody $ encodeJson rec, status: 200, statusText: "OK", headers: Object.empty }

239+ toResponse rec = toResponse $ encodeJson rec

240+

241+instance EncodeJson t => ToResponse (Array t) where

242+ toResponse = encodeJson >>> toResponse

240

243

241instance ToResponse Response where

244instance ToResponse Response where

242 toResponse resp = resp

245 toResponse resp = resp

243

246

247+instance ToResponse Json where

248+ toResponse body = Response { body: JsonResponseBody body, status: 200, statusText: "OK", headers: Object.empty }

249+

244instance

250instance

245 ( ToResponse resp

251 ( ToResponse resp

246 , ToHeaders headers headersList

252 , ToHeaders headers headersList