Adds end to end server-client testing to miso-tests

default.nix

@@ -3,7 +3,7 @@
 with (import ./nix { inherit overlays; });
 
 with pkgs.haskell.lib;
-{
+rec {
   inherit pkgs legacyPkgs;
 
   # hackage release
@@ -24,7 +24,7 @@ with pkgs.haskell.lib;
   # miso x86
   miso-ghc = legacyPkgs.haskell.packages.ghc865.miso;
   miso-ghc-9122 = pkgs.haskell.packages.ghc9122.miso;
-  miso-tests-ghc = pkgs.haskell.packages.ghc9122.miso;
+  miso-tests-ghc = pkgs.haskell.packages.ghc9122.miso-tests;
 
   # sample app legacy build
   inherit (legacyPkgs.haskell.packages.ghc865)
@@ -79,28 +79,59 @@ with pkgs.haskell.lib;
 
   playwright-js = pkgs.writeScriptBin "playwright" ''
     #!${pkgs.stdenv.shell}
+    set -e
     export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers}
     export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH"
     bun install playwright@1.53
-    http-server ${pkgs.pkgsCross.ghcjs.haskell.packages.ghc9122.miso-tests}/bin/component-tests.jsexe &
-    cd tests
-    bun run ../ts/playwright.ts
+    http-server -p 8061 ${miso-tests}/bin/component-tests.jsexe &
+    HTTP_SERVER_PID=$!
+    echo $HTTP_SERVER_PID
+    PW_API_PORT=8060
+    PORT=$PW_API_PORT bun run ./ts/playwright.ts &
+    PLAYWRIGHT_SERVER_PID=$!
+    echo $PLAYWRIGHT_SERVER_PID
+    until curl -sf "http://localhost:$PW_API_PORT/ready"; do sleep 0.1; done
+    echo "Playwright server ready, asking it to start test."
+    curl --fail "http://localhost:$PW_API_PORT/test?port=8061&wait=true"
+    kill $HTTP_SERVER_PID
+    PORT=8062 \
+      PLAYWRIGHT_PORT=$PW_API_PORT \
+      STATIC_DIR="${miso-tests}/bin/integration-tests-client.jsexe/" \
+      BACKEND=GHCJS \
+      ${miso-tests-ghc}/bin/integration-tests-server
     exit_code=$?
-    pkill http-server
+    kill $PLAYWRIGHT_SERVER_PID
     exit "$exit_code"
   '';
 
   playwright-wasm = pkgs.writeScriptBin "playwright" ''
     #!${pkgs.stdenv.shell}
+    set -e
     export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers}
     export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH"
     bun install playwright@1.53
-    cd tests
+    pushd tests
     nix develop .#wasm --command bash -c 'make'
-    http-server ./public &
-    bun run ../ts/playwright.ts
+    http-server -p 8061 ./public &
+    HTTP_SERVER_PID=$!
+    echo $HTTP_SERVER_PID
+    PW_API_PORT=8060
+    echo pwd:
+    pwd
+    PORT=$PW_API_PORT bun run ../ts/playwright.ts &
+    PLAYWRIGHT_SERVER_PID=$!
+    echo $PLAYWRIGHT_SERVER_PID
+    until curl -sf "http://localhost:$PW_API_PORT/ready"; do sleep 0.1; done
+    echo "Playwright server ready, asking it to start test."
+    curl --fail "http://localhost:$PW_API_PORT/test?port=8061&wait=true"
+    kill $HTTP_SERVER_PID
+    PORT=8062 \
+      PLAYWRIGHT_PORT=$PW_API_PORT \
+      STATIC_DIR=./public \
+      BACKEND=WASM \
+      ${miso-tests-ghc}/bin/integration-tests-server
     exit_code=$?
-    pkill http-server
+    kill $PLAYWRIGHT_SERVER_PID
     exit "$exit_code"
   '';
 

nix/haskell/packages/ghc/default.nix

@@ -4,13 +4,21 @@ let
 in
 with pkgs.haskell.lib;
 self: super:
-{
+rec {
   /* miso */
-  miso = self.callCabal2nixWithOptions "miso" source.miso "-ftemplate-haskell" {};
-  miso-tests = self.callCabal2nix "miso-tests" source.miso-tests {};
+  miso = self.callCabal2nixWithOptions "miso" source.miso "-ftemplate-haskell -fssr" {};
 
   /* miso utils */
   miso-from-html = self.callCabal2nix "miso-from-html" source.miso-from-html {};
+  servant-miso-html = self.callCabal2nix "servant-miso-html" source.servant-miso-html {};
+  servant-miso-router = self.callCabal2nix "servant-miso-router" source.servant-miso-router {
+    servant-miso-html = servant-miso-html;
+  };
+
+  miso-tests = self.callCabal2nix "miso-tests" source.miso-tests {
+    servant-miso-router = servant-miso-router;
+    servant-miso-html = servant-miso-html;
+  };
 
   /* examples */
   sample-app = self.callCabal2nix "app" source.sample-app {};

nix/source.nix

@@ -43,6 +43,20 @@ in
     sha256 = "0s6kzqxbshsnqbqfj7rblqkrr5mzkjxknb6k8m8z4h10mcv1zh7j";
   };
 
+  servant-miso-html = fetchFromGitHub {
+    owner = "haskell-miso";
+    repo = "servant-miso-html";
+    rev = "00781d1920795b67e0476b67ed6840c388f29810";
+    sha256 = "sha256-dYPlwSbQ+QXvMeS5tonBVnT9zQGADtohmD/ZAiY/cXA=";
+  };
+
+  servant-miso-router = fetchFromGitHub {
+    owner = "haskell-miso";
+    repo = "servant-miso-router";
+    rev = "0c828e0ba30ee7a446ce8999288b32b7f6425dd1";
+    sha256 = "sha256-2Vkheb2iNDFWNAToO+r8rMY3OAA6LlUtgxiCWRm0wAY=";
+  };
+
   ghcjs-base = fetchFromGitHub {
     owner = "ghcjs";
     repo = "ghcjs-base";

src/Miso/Html/Render.hs

@@ -107,7 +107,7 @@ renderBuilder (VNode ns tag attrs children) = mconcat
   , mconcat [ " " <> intercalate " " (renderAttrs <$> attrs)
             | not (Prelude.null attrs)
             ]
-  , if tag `elem` selfClosing then "/>" else ">"
+  , ">"
   , mconcat
     [ mconcat
       [ foldMap renderBuilder (collapseSiblingTextNodes children)

src/Miso/JSON.hs

@@ -104,7 +104,7 @@ import           Data.Char
 import qualified Data.Map.Strict as M
 import           Data.Map.Strict (Map)
 import           Data.Int
-import           GHC.Natural (naturalToInteger, naturalFromInteger)
+import           GHC.Natural (naturalToInteger, naturalFromInteger )
 import           GHC.TypeLits
 import           Data.Kind
 #ifndef VANILLA

src/Miso/Runtime.hs

@@ -171,12 +171,10 @@ initialize events _componentParentId hydrate isRoot comp@Component {..} getCompo
       (Hydrate, Just m) -> m
       (Draw, _) -> do
         IM.lookup _componentId <$> readIORef components >>= \case
-          Nothing ->
-            pure model
-          Just cs ->
-            -- hot reload scenario, let it flow
-            pure (cs ^. componentModel)
-      _ -> pure model
+          Nothing -> applyParentBindings _componentParentId model bindings
+          Just cs -> pure (cs ^. componentModel)
+      _ -> applyParentBindings _componentParentId model bindings
+
   _componentScripts <- (++) <$> renderScripts scripts <*> renderStyles styles
   _componentDOMRef <- getComponentMountPoint
   _componentIsDirty <- pure False
@@ -328,12 +326,30 @@ propagate
   -> IntMap (ComponentState p m a)
   -> (IntMap (ComponentState p m a), ComponentIds)
 propagate vcompId vcomps =
-  let dfsState = execState synch (dfs vcomps vcompId)
+  let dfsState = execState sync (dfs vcomps vcompId)
   in (_state dfsState, _visited dfsState)
 -----------------------------------------------------------------------------
 -- | Create an empty DFS state
 dfs :: IntMap (ComponentState p m a) -> ComponentId -> DFS p m a
-dfs cs vcompId = DFS cs mempty (pure vcompId)
+dfs cs vcompId = DFS cs mempty (pure vcompId) vcompId
+-----------------------------------------------------------------------------
+-- | Applies ParentToChild & Bidirectional bindings from the parent's current model
+--   to the child's initial model. Safe to call during mount.
+applyParentBindings
+  :: ComponentId
+  -> model
+  -> [Binding parent model]
+  -> IO model
+applyParentBindings pId mdl bindings = do
+  mParent <- IM.lookup pId <$> readIORef components
+  pure $ case mParent of
+    Nothing -> mdl
+    Just parentState ->
+      foldr (applyBinding parentState) mdl bindings
+  where
+    applyBinding parentState (ParentToChild from into) acc = into (from (parentState ^. componentModel)) acc
+    applyBinding parentState (Bidirectional from _ _ into) acc = into (from (parentState ^. componentModel)) acc
+    applyBinding _ _ acc = acc
 -----------------------------------------------------------------------------
 type ComponentIds = IntSet
 -----------------------------------------------------------------------------
@@ -345,9 +361,11 @@ data DFS p m a
     -- ^ visited set
   , _stack :: [ComponentId]
     -- ^ neighbors queue
+  , _triggeredComponent :: ComponentId
+    -- ^ start of the traverse
   }
 -----------------------------------------------------------------------------
-type Synch p m a x = State (DFS p m a) x
+type Sync p m a x = State (DFS p m a) x
 -----------------------------------------------------------------------------
 visited :: Lens (DFS p m a) (ComponentIds)
 visited = lens _visited $ \r x -> r { _visited = x }
@@ -358,40 +376,50 @@ state = lens _state $ \r x -> r { _state = x }
 stack :: Lens (DFS p m a) [ComponentId]
 stack = lens _stack $ \r x -> r { _stack = x }
 -----------------------------------------------------------------------------
-synch :: Synch p m a ()
-synch = mapM_ go =<< pop
+triggeredComponent :: Lens (DFS p m a) ComponentId
+triggeredComponent = lens _triggeredComponent $ \r x -> r { _triggeredComponent = x }
+-----------------------------------------------------------------------------
+sync :: Sync p m a ()
+sync = mapM_ go =<< pop
   where
-    go :: ComponentState p m a -> Synch p m a ()
+    go :: ComponentState p m a -> Sync p m a ()
     go cs = do
-      seen <- IS.member (cs ^. componentId) <$> use visited
+      visited_ <- use visited
+      let seen = IS.member (cs ^. componentId) visited_
       when (not seen) $ do
-        propagateParent cs (cs ^. parentId)
+        let parentSeen = IS.member (cs ^. parentId) visited_
+        when (not parentSeen) $
+            propagateParent cs (cs ^. parentId)
         propagateChildren cs (cs ^. children)
         markVisited (cs ^. componentId)
-        synch
+        sync
 -----------------------------------------------------------------------------
 propagateChildren
   :: forall p m a
    . ComponentState p m a
   -> ComponentIds
-  -> Synch p m a ()
+  -> Sync p m a ()
 propagateChildren currentState childComponents = do
   forM_ (IS.toList childComponents) $ \childId -> do
-    childState <- unsafeCoerce (IM.! childId) <$> use state
-    updatedChild <- unsafeCoerce <$>
-      foldM process childState (childState ^. componentBindings)
-    let isChildDirty =
-          (_componentModelDirty childState)
-          (_componentModel childState)
-          (_componentModel updatedChild)
-    when isChildDirty $ do
-      state.at childId ?= updatedChild { _componentIsDirty = True }
-      visit childId
+    triggeredComponent_ <- use triggeredComponent
+
+    when (childId /= triggeredComponent_) $ do
+      childState <- unsafeCoerce (IM.! childId) <$> use state
+      updatedChild <- unsafeCoerce <$>
+        foldM process childState (childState ^. componentBindings)
+      let isChildDirty =
+            (_componentModelDirty childState)
+            (_componentModel childState)
+            (_componentModel updatedChild)
+      when isChildDirty $ do
+        state.at childId ?= updatedChild { _componentIsDirty = True }
+        visit childId
+
     where
       process
         :: ComponentState m child a
         -> Binding m child
-        -> Synch p m a (ComponentState m child a)
+        -> Sync p m a (ComponentState m child a)
       process childState = \case
         ParentToChild getCurrentField setChildField -> do
           let currentChildModel = childState ^. componentModel
@@ -410,10 +438,11 @@ propagateParent
   :: forall p m a
    . ComponentState p m a
   -> ComponentId
-  -> Synch p m a ()
+  -> Sync p m a ()
 propagateParent currentState parentId_ =
-  IM.lookup parentId_ <$> use state >>= mapM_ \case
-    parentState -> do
+  IM.lookup parentId_ <$> use state >>= \case
+    Nothing -> pure ()
+    Just parentState -> do
       updatedParent <- unsafeCoerce <$>
         foldM process (unsafeCoerce parentState) (currentState ^. componentBindings)
       let isParentDirty =
@@ -427,7 +456,7 @@ propagateParent currentState parentId_ =
     process
       :: ComponentState x p a
       -> Binding p m
-      -> Synch p m a (ComponentState x p a)
+      -> Sync p m a (ComponentState x p a)
     process parentState = \case
       ChildToParent setParentField getCurrentField -> do
         let currentParentModel = parentState ^. componentModel
@@ -442,13 +471,13 @@ propagateParent currentState parentId_ =
       _ ->
         pure parentState
 -----------------------------------------------------------------------------
-markVisited :: ComponentId -> Synch p m a ()
+markVisited :: ComponentId -> Sync p m a ()
 markVisited vcompId = visited.at vcompId ?= ()
 -----------------------------------------------------------------------------
-visit :: ComponentId -> Synch p m a ()
+visit :: ComponentId -> Sync p m a ()
 visit vcompId = stack %= (vcompId:)
 -----------------------------------------------------------------------------
-pop :: Synch p m a (Maybe (ComponentState p m a))
+pop :: Sync p m a (Maybe (ComponentState p m a))
 pop = use stack >>= \case
   [] -> 
     pure Nothing
@@ -1095,7 +1124,7 @@ setAttrs vnode_@(Object jval) attrs snk logLevel events =
 -----------------------------------------------------------------------------
 -- | Registers components in the global state
 registerComponent :: MonadIO m => ComponentState parent model action -> m ()
-registerComponent componentState = liftIO $
+registerComponent componentState = liftIO $ do
   atomicModifyIORef' components $ \cs ->
     (IM.insert (_componentId componentState) componentState cs, ())
 -----------------------------------------------------------------------------

src/Miso/Types.hs

@@ -110,11 +110,7 @@ data Component parent model action
   = Component
   { model :: model
   -- ^ Initial model
-#ifdef SSR
-  , hydrateModel :: Maybe (IO model)
-#else
   , hydrateModel :: Maybe (IO model)
-#endif
   -- ^ Optional 'IO' to load component 'model' state, such as reading data from page.
   --   The resulting 'model' is only used during initial hydration, not on remounts.
   , update :: action -> Effect parent model action

tests/Makefile

@@ -6,12 +6,19 @@ update:
 	wasm32-wasi-cabal update
 
 build:
-	wasm32-wasi-cabal build component-tests
+	wasm32-wasi-cabal build --allow-newer
 	rm -rf public
 	cp -r static public
-	$(eval my_wasm=$(shell wasm32-wasi-cabal list-bin component-tests | tail -n 1))
-	$(shell wasm32-wasi-ghc --print-libdir)/post-link.mjs --input $(my_wasm) --output public/ghc_wasm_jsffi.js
-	cp -v $(my_wasm) public/
+	bash -c '\
+		libdir=$$(wasm32-wasi-ghc --print-libdir); \
+		my_wasm=$$(wasm32-wasi-cabal list-bin component-tests --allow-newer); \
+		$$libdir/post-link.mjs -i "$$my_wasm" -o public/ghc_wasm_jsffi.js; \
+		cp -v "$$my_wasm" public/; \
+		more_wasm=$$(wasm32-wasi-cabal list-bin integration-tests-client --allow-newer); \
+		echo "Processing integration-tests-client: $$more_wasm"; \
+		$$libdir/post-link.mjs -i "$$more_wasm" -o public/wasm.js; \
+		cp -v "$$more_wasm" public/integration-client.wasm \
+	'
 
 optim:
 	wasm-opt -all -O2 public/component-tests.wasm -o public/component-tests.wasm