master..3a2d082 · purestack-dev/todomvc

.gitignore−2

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

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

94+ "lastModified": 1750766736,

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

9696 "owner": "purestack-dev",

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

98− "rev": "c3a0331d62f7f5c9d90012d533e5713095a5fb4e",

98+ "rev": "b137dc5eb0ebfe7071e758b0011cddc18a2eb087",

9999 "type": "github"

100100 },

101101 "original": {

flake.nix+2−4

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

2626 processes = {

2727 spago-frontend = {

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

3030 is_tty = true;

3131 };

3232 spago-backend = {

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

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

4341 };

4442 });

4543 in {

spago.dhall−1

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

1515 , "effect"

1616 , "either"

1717 , "enums"

18− , "exceptions"

1918 , "ezfetch"

2019 , "foldable-traversable"

2120 , "foreign"

src/Backend.purs+17−46

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

44import PureStack.Route

55

66import Bun.Server as Bun

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

7+import Data.Maybe (Maybe)

118import Effect (Effect)

12−import Effect.Aff (launchAff_)

13−import Effect.Aff.Class (liftAff)

14−import Effect.Class (liftEffect)

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

2110import PureStack.Server as Server

2211

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"

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

3313

3414type API =

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

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

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

3721 )

3822

3923main :: Effect Unit

4024main = do

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

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

src/Frontend.purs+14−19

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

77

88import Data.Array ((:))

99import Data.Foldable (for_)

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

1011import Data.URL as URL

1112import Effect (Effect)

1213import Plum as Plum

1314import PureStack.Client (client)

15+import Unsafe.Coerce (unsafeCoerce)

1416

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

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

1618

1719data Msg

1820 = UpdateNewTodo String

19− | SetTodos (Array TodoItem)

2021 | AddNewTodo

21− | TodoAdded

2222

2323main :: Effect Unit

2424main = do

25− origin <- Plum.currentOrigin

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

2725 Plum.run @Model @Msg "plum"

28− { init: \runMsg -> do

29− runMsg $ SetTodos <$> api.getTodos

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

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

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

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

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

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 }

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

4030 , view: \model -> column do

4131 font "sans-serif"

4232

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

5242

5343 onKey "Enter" AddNewTodo

5444

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

56− text todo.text mempty

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

46+ text todo mempty

5747 }

5848

59−getApi = client @API

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

50+ Just x -> x

51+ Nothing -> unsafeCoerce unit

6052

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

22

33import Prelude

44

55import Data.Array as Array

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

7−import Data.URL (URL)

8−import Data.URL as URL

97import Effect (Effect)

10−import Effect.Aff (Aff, launchAff_)

11−import Effect.Class (liftEffect)

128import Effect.Console (log)

13−import Effect.Exception (throw)

149import Effect.Ref as Ref

1510import Foreign.Object as Object

1611import Literals.Undefined (undefined)

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

1813import Snabbdom as Snabbdom

19−import Unsafe.Coerce (unsafeCoerce)

2014import Untagged.Union (asOneOf)

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

2216import Web.HTML (window) as Web

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

2417import 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

2719

2820type Plum msg model =

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

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

21+ { init :: Effect model

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

3123 , view :: model -> UI msg Unit

3224 }

3325

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

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

3729 Just element -> do

3830 let node = Snabbdom.toVNode element

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

4031 patch <- Snabbdom.init

32+ initModel <- plum.init

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

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

6235 view model = do

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

6437 case Array.uncons children of

6538 Just { head: child } -> do

6639 let

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

6950 child

7051 pure $

7152 Snabbdom.h "div"

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

9475 }

9576 []

9677 (asOneOf undefined)

97− initModel <- plum.init

98− ( \aff ->

99− launchAff_

100− ( do

101− msg' <- aff

102− liftEffect $ fire msg'

103− pure unit

104− )

105− )

10678 newNode <- view initModel

10779 newNode_ <- patch node newNode

10880 log "patched"

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

11284

11385outerStyle :: String

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

6565import Data.Traversable (traverse)

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

6767import Data.URL (URL, addSegment)

68−import Debug (traceM)

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

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

7170import Effect.Aff.HTTP.Request as Request

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

7372import Effect.Aff.HTTP.Response as Response

74−import Effect.Class.Console (log)

7573import Foreign (Foreign, unsafeFromForeign, unsafeToForeign)

7674import Foreign.Object (Object)

7775import Foreign.Object as Object

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

9492

9593instance EncodeJson Expr where

9694 encodeJson = case _ of

97− Lit l -> encodeJson l

95+ Lit l -> l

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

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

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

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

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

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

120118

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

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

120+ lit = unwrap >>> lit

129121

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

131123rel = Rel $ RelationVariable (relVar @rel)

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

482474 => Transaction Unit

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

484476 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') } } }

486478 >>= Response.guardStatusOk

487479 pure unit

488480

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

493485 => Rel fields

494486 -> Transaction Unit

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

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

497488 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) } } }

499490 >>= Response.guardStatusOk

500491 pure unit

501492

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

507498 -> Transaction (Array (Record fields))

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

509500 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) } }

511502 Response.guardStatusOk resp

512503 j <- json resp

513504 case decodeRelation @fields @fields' j of

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

519510 . BuildRelation fields fields'

520511 => Json

521512 -> 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')

524514

525515jsonToForeign :: Json -> Foreign

526516jsonToForeign = unsafeCoerce

src/PureStack/Client.purs+5−19

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

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

2626import Data.ArrayBuffer.Types (ArrayBuffer)

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

2828import Data.Map as Map

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

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

241229 fromResponse resp = do

242− fromResponse resp <#> case _ of

243− Nothing -> Nothing

244− Just json ->

245− case decodeJson json of

246− Right x -> Just x

247− Left _ -> Nothing

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

231+ pure $ case decodeJson json of

232+ Right x -> Just x

233+ Left _ -> Nothing

248234

249235instance FromResponse Unit where

250236 fromResponse _ = pure $ Just unit

src/PureStack/Server.purs+2−8

@@ -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 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

144144 serveRoute { path, verb } = do

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

146146 assert $ path == []

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

236236 toResponse :: r -> Response

237237

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

239− toResponse rec = toResponse $ encodeJson rec

240−

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

242− toResponse = encodeJson >>> toResponse

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

243240

244241instance ToResponse Response where

245242 toResponse resp = resp

246243

247−instance ToResponse Json where

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

249−

250244instance

251245 ( ToResponse resp

252246 , ToHeaders headers headersList