3a2d082...master · purestack-dev/todomvc

.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+4−2

@@ -26,18 +26,20 @@

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

3838 project-m36.command = "${

3939 project-m36-rest.packages.${system}.default

4040 }/bin/project-m36-rest";

41+ proxy.command =

42+ "${pkgs.reproxy}/bin/reproxy -l=localhost:3001 --static.enabled --static.rule='*,^/api/(.*),http://localhost:3000/$$1' --assets.location=. --assets.spa --logger.stdout";

4143 };

4244 });

4345 in {

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

55

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+19−14

@@ -7,26 +7,36 @@ import Prim

77

88import Data.Array ((:))

99import Data.Foldable (for_)

10−import Data.Maybe (Maybe(..))

1110import Data.URL as URL

1211import Effect (Effect)

1312import Plum as Plum

1413import PureStack.Client (client)

15−import Unsafe.Coerce (unsafeCoerce)

1614

17−type Model = { newTodo :: String, todos :: Array String }

15+type Model = { newTodo :: String, todos :: Array TodoItem }

1816

1917data Msg

2018 = UpdateNewTodo String

19+ | SetTodos (Array TodoItem)

2120 | AddNewTodo

21+ | TodoAdded

2222

2323main :: Effect Unit

2424main = do

25+ origin <- Plum.currentOrigin

26+ let api = getApi (origin `URL.addSegment` "api")

2527 Plum.run @Model @Msg "plum"

26− { init: pure { newTodo: "", todos: [] }

27− , update: \msg model -> case msg of

28+ { init: \runMsg -> do

29+ runMsg $ SetTodos <$> api.getTodos

30+ pure { newTodo: "", todos: [] }

31+ , update: \runMsg msg model -> case msg of

2832 UpdateNewTodo newTodo -> pure model { newTodo = newTodo }

29− AddNewTodo -> pure model { newTodo = "", todos = model.newTodo : model.todos }

33+ AddNewTodo -> do

34+ runMsg $ api.createTodo (TodoItem { text: model.newTodo, done: false }) $> TodoAdded

35+ pure model

36+ TodoAdded -> do

37+ runMsg $ SetTodos <$> api.getTodos

38+ pure model

39+ SetTodos todos -> pure model { todos = todos }

3040 , view: \model -> column do

3141 font "sans-serif"

3242

@@ -42,14 +52,9 @@ main = do

4252

4353 onKey "Enter" AddNewTodo

4454

45− for_ model.todos $ \todo -> do

46− text todo mempty

55+ for_ model.todos $ \(TodoItem todo) -> do

56+ text todo.text mempty

4757 }

4858

49−url = case URL.fromString "localhost" of

50− Just x -> x

51− Nothing -> unsafeCoerce unit

59+getApi = client @API

5260

53−x = client @API url

54−

55−foo = x.deep.something

src/Plum.purs+50−15

@@ -1,25 +1,33 @@

1−module Plum (Plum, run) where

1+module Plum (Plum, run, currentOrigin) where

22

33import Prelude

44

55import Data.Array as Array

66import Data.Maybe (Maybe(..))

7+import Data.URL (URL)

8+import Data.URL as URL

79import Effect (Effect)

10+import Effect.Aff (Aff, launchAff_)

11+import Effect.Class (liftEffect)

812import Effect.Console (log)

13+import Effect.Exception (throw)

914import Effect.Ref as Ref

1015import Foreign.Object as Object

1116import Literals.Undefined (undefined)

1217import Plum.View (GenericUI(..), UI, grow)

1318import Snabbdom as Snabbdom

19+import Unsafe.Coerce (unsafeCoerce)

1420import Untagged.Union (asOneOf)

1521import Web.DOM.NonElementParentNode (getElementById) as Web

1622import Web.HTML (window) as Web

23+import Web.HTML.Event.EventTypes (invalid)

1724import Web.HTML.HTMLDocument (toNonElementParentNode) as Web

18−import Web.HTML.Window (document) as Web

25+import Web.HTML.Location as Location

26+import Web.HTML.Window (document, location) as Web

1927

2028type Plum msg model =

21− { init :: Effect model

22− , update :: msg -> model -> Effect model

29+ { init :: (Aff msg -> Effect Unit) -> Effect model

30+ , update :: (Aff msg -> Effect Unit) -> msg -> model -> Effect model

2331 , view :: model -> UI msg Unit

2432 }

2533

@@ -28,25 +36,36 @@ run id plum = do

2836 Web.window >>= Web.document >>= Web.getElementById id <<< Web.toNonElementParentNode >>= case _ of

2937 Just element -> do

3038 let node = Snabbdom.toVNode element

39+ modelRef <- Ref.new { model: unsafeCoerce undefined, lastNode: node }

3140 patch <- Snabbdom.init

32− initModel <- plum.init

33− modelRef <- Ref.new { model: initModel, lastNode: node }

3441 let

42+ fire =

43+ ( \msg -> do

44+ log "in"

45+ { model: m, lastNode } <- Ref.read modelRef

46+ m_ <- plum.update

47+ ( \aff ->

48+ launchAff_

49+ ( do

50+ msg' <- aff

51+ liftEffect $ fire msg'

52+ pure unit

53+ )

54+ )

55+ msg

56+ m

57+ node' <- view m_

58+ newNode <- patch lastNode node'

59+ Ref.write { model: m_, lastNode: newNode } modelRef

60+ pure unit

61+ )

3562 view model = do

3663 let UI { children } _ = plum.view model

3764 case Array.uncons children of

3865 Just { head: child } -> do

3966 let

4067 { node, style } = grow

41− ( \msg -> do

42− log "in"

43− { model: m, lastNode } <- Ref.read modelRef

44− m_ <- plum.update msg m

45− node <- view m_

46− newNode <- patch lastNode node

47− Ref.write { model: m_, lastNode: newNode } modelRef

48− pure unit

49− )

68+ fire

5069 child

5170 pure $

5271 Snabbdom.h "div"

@@ -75,6 +94,15 @@ run id plum = do

7594 }

7695 []

7796 (asOneOf undefined)

97+ initModel <- plum.init

98+ ( \aff ->

99+ launchAff_

100+ ( do

101+ msg' <- aff

102+ liftEffect $ fire msg'

103+ pure unit

104+ )

105+ )

78106 newNode <- view initModel

79107 newNode_ <- patch node newNode

80108 log "patched"

@@ -84,3 +112,10 @@ run id plum = do

84112

85113outerStyle :: String

86114outerStyle = "html,body{height:100%;padding:0;margin:0;}"

115+

116+currentOrigin :: Effect URL

117+currentOrigin = do

118+ s <- Web.window >>= Web.location >>= Location.origin

119+ case URL.fromString s of

120+ Nothing -> throw "window.location.origin returned an invalid url"

121+ Just url -> pure url

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