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

.gitignore+2

since splitsnapshots

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

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

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

38 project-m36.command = "${

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

40 }/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";

41 };

43 };

42 });

44 });

43 in {

45 in {

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

5

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

11

22

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"

13

33

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 )

22

38

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

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

7

8import Data.Array ((:))

9import Data.Foldable (for_)

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

11import Data.URL as URL

10import Data.URL as URL

12import Effect (Effect)

11import Effect (Effect)

13import Plum as Plum

12import Plum as Plum

14import PureStack.Client (client)

13import PureStack.Client (client)

15−import Unsafe.Coerce (unsafeCoerce)

16

14

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

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

18

16

19data Msg

17data Msg

20 = UpdateNewTodo String

18 = UpdateNewTodo String

19+ | SetTodos (Array TodoItem)

21 | AddNewTodo

20 | AddNewTodo

21+ | TodoAdded

22

23main :: Effect Unit

24main = do

25+ origin <- Plum.currentOrigin

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

25 Plum.run @Model @Msg "plum"

27 Plum.run @Model @Msg "plum"

28+ { init: \runMsg -> do

29+ runMsg $ SetTodos <$> api.getTodos

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

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

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

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

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

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

30 , view: \model -> column do

40 , view: \model -> column do

31 font "sans-serif"

41 font "sans-serif"

32

42

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

42

52

43 onKey "Enter" AddNewTodo

53 onKey "Enter" AddNewTodo

44

54

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

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

46− text todo mempty

56+ text todo.text mempty

47 }

57 }

48

58

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

59+getApi = client @API

50− Just x -> x

51− Nothing -> unsafeCoerce unit

52

60

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

2

3import Prelude

4

5import Data.Array as Array

6import Data.Maybe (Maybe(..))

7+import Data.URL (URL)

8+import Data.URL as URL

7import Effect (Effect)

9import Effect (Effect)

10+import Effect.Aff (Aff, launchAff_)

11+import Effect.Class (liftEffect)

8import Effect.Console (log)

12import Effect.Console (log)

13+import Effect.Exception (throw)

9import Effect.Ref as Ref

14import Effect.Ref as Ref

10import Foreign.Object as Object

15import Foreign.Object as Object

11import Literals.Undefined (undefined)

16import Literals.Undefined (undefined)

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

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

13import Snabbdom as Snabbdom

18import Snabbdom as Snabbdom

19+import Unsafe.Coerce (unsafeCoerce)

14import Untagged.Union (asOneOf)

20import Untagged.Union (asOneOf)

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

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

16import Web.HTML (window) as Web

22import Web.HTML (window) as Web

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

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

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

25+import Web.HTML.Location as Location

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

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

19

27

20type Plum msg model =

28type Plum msg model =

21− { init :: Effect model

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

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

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

23 , view :: model -> UI msg Unit

31 , view :: model -> UI msg Unit

24 }

32 }

25

33

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

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

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

29 Just element -> do

37 Just element -> do

30 let node = Snabbdom.toVNode element

38 let node = Snabbdom.toVNode element

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

31 patch <- Snabbdom.init

40 patch <- Snabbdom.init

32− initModel <- plum.init

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

34 let

41 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+ )

35 view model = do

62 view model = do

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

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

37 case Array.uncons children of

64 case Array.uncons children of

38 Just { head: child } -> do

65 Just { head: child } -> do

39 let

66 let

40 { node, style } = grow

67 { node, style } = grow

41− ( \msg -> do

68+ fire

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

50 child

69 child

51 pure $

70 pure $

52 Snabbdom.h "div"

71 Snabbdom.h "div"

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

75 }

94 }

76 []

95 []

77 (asOneOf undefined)

96 (asOneOf undefined)

97+ initModel <- plum.init

98+ ( \aff ->

99+ launchAff_

100+ ( do

101+ msg' <- aff

102+ liftEffect $ fire msg'

103+ pure unit

104+ )

105+ )

78 newNode <- view initModel

106 newNode <- view initModel

79 newNode_ <- patch node newNode

107 newNode_ <- patch node newNode

80 log "patched"

108 log "patched"

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

84

112

85outerStyle :: String

113outerStyle :: String

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

114outerStyle = "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

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

92

94

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

23

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