c8f9b92 · purestack-dev/todomvc

git.iko.soy/purestack-dev/todomvc

got backend working

commitc8f9b924baeae46239f38a32227e0f9e6685e8cc authoriko <mail@iko.soy> dateFri 4 Jul 2025, 16:45 (1 year ago) parent3a2d082

9 files changed+98−37

compare with master

unifiedsplit

.gitignore+2 flake.lock+3−3 flake.nix+2−2 spago.dhall+1 src/Backend.purs+46−17 src/Frontend.purs−1 src/ProjectM36.purs+17−7 src/PureStack/Client.purs+19−5 src/PureStack/Server.purs+8−2

.gitignore+2

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

1313result

1414index.js

1515m36

16+backend.js.map

17+frontend.js.map

flake.lock+3−3

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

9191 "stacklock2nix": "stacklock2nix"

9292 },

9393 "locked": {

94− "lastModified": 1750766736,

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

94+ "lastModified": 1751636615,

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

9696 "owner": "purestack-dev",

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

98− "rev": "b137dc5eb0ebfe7071e758b0011cddc18a2eb087",

98+ "rev": "c3a0331d62f7f5c9d90012d533e5713095a5fb4e",

9999 "type": "github"

100100 },

101101 "original": {

flake.nix+2−2

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

2626 processes = {

2727 spago-frontend = {

2828 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";

3030 is_tty = true;

3131 };

3232 spago-backend = {

3333 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";

3535 is_tty = true;

3636 };

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

spago.dhall+1

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

1515 , "effect"

1616 , "either"

1717 , "enums"

18+ , "exceptions"

1819 , "ezfetch"

1920 , "foldable-traversable"

2021 , "foreign"

src/Backend.purs+46−17

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

44import PureStack.Route

66import Bun.Server as Bun

7−import Data.Maybe (Maybe)

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

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

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

10+import Data.URL as URL

811import Effect (Effect)

12+import Effect.Aff (launchAff_)

13+import Effect.Aff.Class (liftAff)

14+import Effect.Class (liftEffect)

915import 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)

1021import PureStack.Server as Server

1122

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"

1333

1434type API =

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

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

17− , deep ::

18− "deep" /

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

20− )

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

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

2137 )

2238

2339main :: Effect Unit

2440main = do

25− log "🍝"

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

27− { handlers:

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

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

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

31− }

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

33− }

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+

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

52+ { handlers:

53+ { getTodos: do

54+ liftAff $ withTransaction m36Connection $ do

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

56+ , createTodo: \todo -> do

57+ liftAff $ withTransaction m36Connection $ do

58+ insert @TodoItem $ lit [ todo ]

59+ pure unit

60+ }

61+ , middlewares: {}

62+ }

src/Frontend.purs−1

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

5252

5353x = client @API url

5454

55−foo = x.deep.something

src/ProjectM36.purs+17−7

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

6565import Data.Traversable (traverse)

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

6767import Data.URL (URL, addSegment)

68+import Debug (traceM)

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

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

7071import Effect.Aff.HTTP.Request as Request

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

7273import Effect.Aff.HTTP.Response as Response

74+import Effect.Class.Console (log)

7375import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

7476import Foreign.Object (Object)

7577import Foreign.Object as Object

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

9294

9395instance EncodeJson Expr where

9496 encodeJson = case _ of

95− Lit l -> l

97+ Lit l -> encodeJson l

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

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

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

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

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

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

118120

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

120− lit = unwrap >>> lit

121+else instance

122+ ( Newtype r (Record fields)

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

124+ , RowToList fields fields'

125+ , Relatable fields fields'

126+ ) =>

127+ LiteralRelation (Array r) fields where

128+ lit = map unwrap >>> lit

121129

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

123131rel = Rel $ RelationVariable (relVar @rel)

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

474482 => Transaction Unit

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

476484 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' } } }

478486 >>= Response.guardStatusOk

479487 pure unit

480488

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

485493 => Rel fields

486494 -> Transaction Unit

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

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

488497 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 } } }

490499 >>= Response.guardStatusOk

491500 pure unit

492501

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

498507 -> Transaction (Array (Record fields))

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

500509 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 } }

502511 Response.guardStatusOk resp

503512 j <- json resp

504513 case decodeRelation @fields @fields' j of

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

510519 . BuildRelation fields fields'

511520 => Json

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

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

522+decodeRelation j = do

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

514524

515525jsonToForeign :: Json -> Foreign

516526jsonToForeign = unsafeCoerce

src/PureStack/Client.purs+19−5

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

2222import PureStack.Route

2323

2424import 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)

2626import Data.ArrayBuffer.Types (ArrayBuffer)

2727import Data.Either (Either(..))

2828import Data.Map as Map

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

225225class FromResponse r where

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

227227

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+

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

229241 fromResponse resp = do

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

231− pure $ case decodeJson json of

232− Right x -> Just x

233− Left _ -> Nothing

242+ fromResponse resp <#> case _ of

243+ Nothing -> Nothing

244+ Just json ->

245+ case decodeJson json of

246+ Right x -> Just x

247+ Left _ -> Nothing

234248

235249instance FromResponse Unit where

236250 fromResponse _ = pure $ Just unit

src/PureStack/Server.purs+8−2

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

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

141141 resp <- nt handler

142142 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

144144 serveRoute { path, verb } = do

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

146146 assert $ path == []

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

236236 toResponse :: r -> Response

237237

238238instance 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

240243

241244instance ToResponse Response where

242245 toResponse resp = resp

243246

247+instance ToResponse Json where

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

249+

244250instance

245251 ( ToResponse resp

246252 , ToHeaders headers headersList