master..3a2d082 · purestack-dev/todomvc

.gitignore−2

since splitsnapshots

unifiedsplit

@@ -13,5 +13,3 @@ 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": 1751636615,

94+ "lastModified": 1750766736,

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

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

96 "owner": "purestack-dev",

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

98− "rev": "c3a0331d62f7f5c9d90012d533e5713095a5fb4e",

98+ "rev": "b137dc5eb0ebfe7071e758b0011cddc18a2eb087",

99 "type": "github"

100 },

101 "original": {

flake.nix+2−4

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

26 processes = {

27 spago-frontend = {

28 command =

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

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

30 is_tty = true;

31 };

32 spago-backend = {

33 command =

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

34+ "${pkgs.spago}/bin/spago bundle-app --watch --main Backend --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";

43 };

41 };

44 });

42 });

45 in {

43 in {

spago.dhall−1

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

15 , "effect"

16 , "either"

17 , "enums"

18− , "exceptions"

19 , "ezfetch"

18 , "ezfetch"

20 , "foldable-traversable"

19 , "foldable-traversable"

21 , "foreign"

20 , "foreign"

src/Backend.purs+17−46

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

4import PureStack.Route

5

6import Bun.Server as Bun

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

8−import Data.Maybe (Maybe(..))

7+import Data.Maybe (Maybe)

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

10−import Data.URL as URL

11import Effect (Effect)

8import Effect (Effect)

12−import Effect.Aff (launchAff_)

13−import Effect.Aff.Class (liftAff)

14−import Effect.Class (liftEffect)

15import Effect.Console (log)

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

21import PureStack.Server as Server

10import PureStack.Server as Server

22

11

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

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

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"

33

13

34type API =

14type API =

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

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

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

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

37 )

21 )

38

22

39main :: Effect Unit

23main :: Effect Unit

40main = do

24main = do

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

25+ log "🍝"

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

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

52− { handlers:

27+ { handlers:

53− { getTodos: do

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

54− liftAff $ withTransaction m36Connection $ do

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

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

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

56− , createTodo: \todo -> do

57− liftAff $ withTransaction m36Connection $ do

58− insert @TodoItem $ lit [ todo ]

59− pure unit

60− }

31+ }

61− , middlewares: {}

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

62− }

33+ }

src/Frontend.purs+14−19

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

7

8import Data.Array ((:))

9import Data.Foldable (for_)

10+import Data.Maybe (Maybe(..))

10import Data.URL as URL

11import Data.URL as URL

11import Effect (Effect)

12import Effect (Effect)

12import Plum as Plum

13import Plum as Plum

13import PureStack.Client (client)

14import PureStack.Client (client)

15+import Unsafe.Coerce (unsafeCoerce)

14

16

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

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

16

18

17data Msg

19data Msg

18 = UpdateNewTodo String

20 = UpdateNewTodo String

19− | SetTodos (Array TodoItem)

20 | AddNewTodo

21 | AddNewTodo

21− | TodoAdded

22

23main :: Effect Unit

24main = do

25− origin <- Plum.currentOrigin

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

27 Plum.run @Model @Msg "plum"

25 Plum.run @Model @Msg "plum"

28− { init: \runMsg -> do

29− runMsg $ SetTodos <$> api.getTodos

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

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

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

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

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

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

33− AddNewTodo -> do

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

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 }

40 , view: \model -> column do

30 , view: \model -> column do

41 font "sans-serif"

31 font "sans-serif"

42

32

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

52

42

53 onKey "Enter" AddNewTodo

43 onKey "Enter" AddNewTodo

54

44

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

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

56− text todo.text mempty

46+ text todo mempty

57 }

47 }

58

48

59−getApi = client @API

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

50+ Just x -> x

51+ Nothing -> unsafeCoerce unit

60

52

53+x = client @API url

54+

55+foo = x.deep.something

src/Plum.purs+15−50

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

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

1+module Plum (Plum, run) 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

9import Effect (Effect)

7import Effect (Effect)

10−import Effect.Aff (Aff, launchAff_)

11−import Effect.Class (liftEffect)

12import Effect.Console (log)

8import Effect.Console (log)

13−import Effect.Exception (throw)

14import Effect.Ref as Ref

9import Effect.Ref as Ref

15import Foreign.Object as Object

10import Foreign.Object as Object

16import Literals.Undefined (undefined)

11import Literals.Undefined (undefined)

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

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

18import Snabbdom as Snabbdom

13import Snabbdom as Snabbdom

19−import Unsafe.Coerce (unsafeCoerce)

20import Untagged.Union (asOneOf)

14import Untagged.Union (asOneOf)

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

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

22import Web.HTML (window) as Web

16import Web.HTML (window) as Web

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

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

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

25−import Web.HTML.Location as Location

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

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

27

19

28type Plum msg model =

20type Plum msg model =

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

21+ { init :: Effect model

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

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

31 , view :: model -> UI msg Unit

23 , view :: model -> UI msg Unit

32 }

24 }

33

25

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

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

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

37 Just element -> do

29 Just element -> do

38 let node = Snabbdom.toVNode element

30 let node = Snabbdom.toVNode element

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

40 patch <- Snabbdom.init

31 patch <- Snabbdom.init

32+ initModel <- plum.init

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

41 let

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

62 view model = do

35 view model = do

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

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

64 case Array.uncons children of

37 case Array.uncons children of

65 Just { head: child } -> do

38 Just { head: child } -> do

66 let

39 let

67 { node, style } = grow

40 { node, style } = grow

68− fire

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

69 child

50 child

70 pure $

51 pure $

71 Snabbdom.h "div"

52 Snabbdom.h "div"

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

94 }

75 }

95 []

76 []

96 (asOneOf undefined)

77 (asOneOf undefined)

97− initModel <- plum.init

98− ( \aff ->

99− launchAff_

100− ( do

101− msg' <- aff

102− liftEffect $ fire msg'

103− pure unit

104− )

105− )

106 newNode <- view initModel

78 newNode <- view initModel

107 newNode_ <- patch node newNode

79 newNode_ <- patch node newNode

108 log "patched"

80 log "patched"

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

112

84

113outerStyle :: String

85outerStyle :: String

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

86outerStyle = "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+7−17

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

65import Data.Traversable (traverse)

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

67import Data.URL (URL, addSegment)

68−import Debug (traceM)

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

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

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

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

71import Effect.Aff.HTTP.Request as Request

70import Effect.Aff.HTTP.Request as Request

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

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

73import Effect.Aff.HTTP.Response as Response

72import Effect.Aff.HTTP.Response as Response

74−import Effect.Class.Console (log)

75import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

73import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

76import Foreign.Object (Object)

74import Foreign.Object (Object)

77import Foreign.Object as Object

75import Foreign.Object as Object

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

94

92

95instance EncodeJson Expr where

93instance EncodeJson Expr where

96 encodeJson = case _ of

94 encodeJson = case _ of

97− Lit l -> encodeJson l

95+ Lit l -> l

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

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

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

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

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

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

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

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

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

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

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

120

118

121−else instance

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

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

120+ lit = unwrap >>> lit

129

121

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

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

131rel = Rel $ RelationVariable (relVar @rel)

123rel = Rel $ RelationVariable (relVar @rel)

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

482 => Transaction Unit

474 => Transaction Unit

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

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

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

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

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

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

486 >>= Response.guardStatusOk

478 >>= Response.guardStatusOk

487 pure unit

479 pure unit

488

480

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

493 => Rel fields

485 => Rel fields

494 -> Transaction Unit

486 -> Transaction Unit

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

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

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

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

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

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

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

499 >>= Response.guardStatusOk

490 >>= Response.guardStatusOk

500 pure unit

491 pure unit

501

492

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

507 -> Transaction (Array (Record fields))

498 -> Transaction (Array (Record fields))

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

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

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

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

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

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

511 Response.guardStatusOk resp

502 Response.guardStatusOk resp

512 j <- json resp

503 j <- json resp

513 case decodeRelation @fields @fields' j of

504 case decodeRelation @fields @fields' j of

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

519 . BuildRelation fields fields'

510 . BuildRelation fields fields'

520 => Json

511 => Json

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

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

522−decodeRelation j = do

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

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

524

514

525jsonToForeign :: Json -> Foreign

515jsonToForeign :: Json -> Foreign

526jsonToForeign = unsafeCoerce

516jsonToForeign = unsafeCoerce

src/PureStack/Client.purs+5−19

@@ -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, JsonDecodeError, decodeJson, encodeJson)

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

26import Data.ArrayBuffer.Types (ArrayBuffer)

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

28import Data.Map as Map

@@ -225,26 +225,12 @@ 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−

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

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

241 fromResponse resp = do

229 fromResponse resp = do

242− fromResponse resp <#> case _ of

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

243− Nothing -> Nothing

244− Just json ->

245− case decodeJson json of

231+ pure $ case decodeJson json of

246− Right x -> Just x

232+ Right x -> Just x

247− Left _ -> Nothing

233+ Left _ -> Nothing

248

234

249instance FromResponse Unit where

235instance FromResponse Unit where

250 fromResponse _ = pure $ Just unit

236 fromResponse _ = pure $ Just unit

src/PureStack/Server.purs+2−8

@@ -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 req Unit) (req -> m Unit) middlewares m where

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

144 serveRoute { path, verb } = do

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

146 assert $ path == []

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

236 toResponse :: r -> Response

237

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

239− toResponse rec = toResponse $ encodeJson rec

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

240−

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

242− toResponse = encodeJson >>> toResponse

243

240

244instance ToResponse Response where

241instance ToResponse Response where

245 toResponse resp = resp

242 toResponse resp = resp

246

243

247−instance ToResponse Json where

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

249−

250instance

244instance

251 ( ToResponse resp

245 ( ToResponse resp

252 , ToHeaders headers headersList

246 , ToHeaders headers headersList