bfe12eb · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

webdriver tests and hydration fixes

bfe12ebTom Smalley8 years ago

reflex-dom-core/reflex-dom-core.cabal+31

compare with develop

unifiedsplit

@@ -151,6 +151,37 @@ test-suite hlint

151 main-is: hlint.hs

152 type: exitcode-stdio-1.0

153

154+test-suite hydration

155+ build-depends: base

156+ , aeson

157+ , bytestring

158+ , containers

159+ , exceptions

160+ , ghcjs-dom

161+ , hspec

162+ , http-types

163+ , HUnit

164+ , jsaddle

165+ , jsaddle-warp

166+ , random

167+ , reflex == 0.5.*

168+ , reflex-dom-core

169+ , silently

170+ , temporary

171+ , text

172+ , wai

173+ , wai-websockets

174+ , warp

175+ , webdriver

176+ , websockets

177+ hs-source-dirs: test

178+ ghc-options: -rtsopts -with-rtsopts=-T -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

179+ ghc-prof-options: -fprof-auto -optP-DPROFILING

180+ main-is: hydration.hs

181+ type: exitcode-stdio-1.0

182+ if !os(linux) || !arch(x86_64)-- || impl(ghc >= 8.4.0)

183+ buildable: False

184+

154-- broken test on base 4.11 & ghc 8.4.3

185-- broken test on base 4.11 & ghc 8.4.3

155-- needs to be updated for changes in GHC.Stats

186-- needs to be updated for changes in GHC.Stats

156test-suite gc

187test-suite gc

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+86−67

@@ -84,7 +84,7 @@ import Data.Default

84import Data.Dependent.Map (DMap)

85import qualified Data.Dependent.Map as DMap

86import Data.Dependent.Sum

87−import Data.Foldable (foldl')

87+import Data.Foldable (foldl', for_)

88import Data.Functor.Compose

89import Data.Functor.Constant

90import Data.Functor.Misc

@@ -204,8 +204,9 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati

204addHydrationStepWithSetup setup f = getHydrationMode >>= \case

205 HydrationMode_Immediate -> pure ()

206 HydrationMode_Hydrating -> do

207− pb <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover -- Use postBuild as a proxy for switchover to immediate mode TODO is this correct?

207+ switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

208+ --s <- lift setup

208− (s, _) <- lift $ runWithReplace setup $ return () <$ pb

209+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above

209 HydrationDomBuilderT $ modify' (>> f s)

210 HydrationDomBuilderT $ modify' (>> f s)

210

211

211-- | Add a hydration step

212-- | Add a hydration step

@@ -352,8 +353,6 @@ makeNodeInternal

352 :: forall node t m. (MonadJSM m, IsNode node, Typeable node)

353 :: forall node t m. (MonadJSM m, IsNode node, Typeable node)

353 => HydrationDomBuilderT t m node -> HydrationDomBuilderT t m node

354 => HydrationDomBuilderT t m node -> HydrationDomBuilderT t m node

354makeNodeInternal mkNode = do

355makeNodeInternal mkNode = do

355− liftIO $ putStr $ show (typeRep (Proxy :: Proxy node)) <> ": "

356− liftIO $ putStrLn $ "Not in hydration mode, creating node"

357 n <- mkNode

356 n <- mkNode

358 append $ toNode n

357 append $ toNode n

359 return n

358 return n

@@ -367,21 +366,14 @@ hydrateNode

367 => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

366 => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

368hydrateNode check constructor = do

367hydrateNode check constructor = do

369 parent <- askParent

368 parent <- askParent

370− liftIO $ putStr $ show (typeRep constructor) <> ": "

371 lastHydrationNode <- getPreviousNode

369 lastHydrationNode <- getPreviousNode

372 let go mLastNode = do

370 let go mLastNode = do

373 node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

371 node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

374 DOM.castTo constructor node >>= \case

372 DOM.castTo constructor node >>= \case

375− Nothing -> do

376− liftIO $ putStr $ "Wrong node type, skipping... "

377− go (Just node)

373+ Nothing -> go (Just node)

378 Just tn -> check tn >>= \case

374 Just tn -> check tn >>= \case

379− True -> do

380− liftIO $ putStr $ "Using existing node... "

381− return tn

375+ True -> return tn

382− False -> do

383− liftIO $ putStr $ "Node failed check, skipping... "

384− go (Just node)

376+ False -> go (Just node)

385 n <- go lastHydrationNode

377 n <- go lastHydrationNode

386 setPreviousNode $ Just $ toNode n

378 setPreviousNode $ Just $ toNode n

387 return n

379 return n

@@ -421,7 +413,7 @@ makeElement

421 => Text

413 => Text

422 -> ElementConfig er t GhcjsDomSpace

414 -> ElementConfig er t GhcjsDomSpace

423 -> HydrationDomBuilderT t m a

415 -> HydrationDomBuilderT t m a

424− -> HydrationDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

416+ -> HydrationDomBuilderT t m ((Element er GhcjsDomSpace t, a), IORef DOM.Element)

425makeElement elementTag cfg child = do

417makeElement elementTag cfg child = do

426 doc <- askDocument

418 doc <- askDocument

427 ctx <- askJSM

419 ctx <- askJSM

@@ -469,18 +461,21 @@ makeElement elementTag cfg child = do

469 events <- askEvents

461 events <- askEvents

470 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg

462 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg

471 es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e

463 es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e

464+ e' <- liftIO $ newIORef e

472− return ((Element es e, result), e)

465+ return ((Element es e, result), e')

473 HydrationMode_Hydrating -> do

466 HydrationMode_Hydrating -> do

474 -- Schedule everything for after postBuild, except for getting the result itself

467 -- Schedule everything for after postBuild, except for getting the result itself

475 parent <- liftIO $ newIORef $ error "Parent not yet initialized"

468 parent <- liftIO $ newIORef $ error "Parent not yet initialized"

469+ e' <- liftIO $ newIORef $ error "makeElement: Element not yet initialized"

476 env <- HydrationDomBuilderT ask

470 env <- HydrationDomBuilderT ask

477− let env' = env { _hydrationDomBuilderEnv_parent = parent}

471+ let env' = env { _hydrationDomBuilderEnv_parent = parent }

478 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') (pure ())

472 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') (pure ())

479 wrapResult <- liftIO newEmptyMVar

473 wrapResult <- liftIO newEmptyMVar

480 let activateElement = do

474 let activateElement = do

481 e <- hydrateNode hasSSRAttribute DOM.Element

475 e <- hydrateNode hasSSRAttribute DOM.Element

482 -- Update the parent node used by the children

476 -- Update the parent node used by the children

483 liftIO $ writeIORef parent $ toNode e

477 liftIO $ writeIORef parent $ toNode e

478+ liftIO $ writeIORef e' e

484 -- Setup events, store the result so we can wait on it later

479 -- Setup events, store the result so we can wait on it later

485 refs <- wrap events e $ extractRawElementConfig cfg

480 refs <- wrap events e $ extractRawElementConfig cfg

486 liftIO $ putMVar wrapResult (e, refs)

481 liftIO $ putMVar wrapResult (e, refs)

@@ -508,7 +503,7 @@ makeElement elementTag cfg child = do

508 Just c -> c

503 Just c -> c

509

504

510 let dummyElement = error "makeElement: DOM.Element"

505 let dummyElement = error "makeElement: DOM.Element"

511− return ((Element es dummyElement, result), dummyElement)

506+ return ((Element es dummyElement, result), e')

512

507

513{-# INLINABLE textNodeInternal #-}

508{-# INLINABLE textNodeInternal #-}

514textNodeInternal :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t) => Text -> Maybe (Event t Text) -> HydrationDomBuilderT t m DOM.Text

509textNodeInternal :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t) => Text -> Maybe (Event t Text) -> HydrationDomBuilderT t m DOM.Text

@@ -566,7 +561,6 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case

566 HydrationMode_Hydrating -> do

561 HydrationMode_Hydrating -> do

567 doc <- askDocument

562 doc <- askDocument

568 addHydrationStep $ do

563 addHydrationStep $ do

569− liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)

570 n <- hydrateNode (const $ pure True) DOM.Comment

564 n <- hydrateNode (const $ pure True) DOM.Comment

571 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

565 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

572 pure $ error "commentNodeInternal: DOM.Comment"

566 pure $ error "commentNodeInternal: DOM.Comment"

@@ -601,14 +595,11 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

601 Just key -> do

595 Just key -> do

602 -- Replace the comment with an (invisible) text node

596 -- Replace the comment with an (invisible) text node

603 textNode <- createTextNode doc ("" :: Text)

597 textNode <- createTextNode doc ("" :: Text)

604− liftIO $ putStr "Replacing existing comment..."

605 Node.replaceChild_ parent textNode comment

598 Node.replaceChild_ parent textNode comment

606 pure (textNode, key)

599 pure (textNode, key)

607 Nothing -> do

600 Nothing -> do

608− liftIO $ putStr "Bad key in comment, skipping... "

609 go key0 (Just node)

601 go key0 (Just node)

610 Nothing -> do

602 Nothing -> do

611− liftIO $ putStr "Not a comment, skipping... "

612 go key0 (Just node)

603 go key0 (Just node)

613 switchComment = do

604 switchComment = do

614 key0 <- liftIO $ readIORef key0Ref

605 key0 <- liftIO $ readIORef key0Ref

@@ -646,73 +637,100 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

646 type DomBuilderSpace (HydrationDomBuilderT t m) = GhcjsDomSpace

637 type DomBuilderSpace (HydrationDomBuilderT t m) = GhcjsDomSpace

647 {-# INLINABLE textNode #-}

638 {-# INLINABLE textNode #-}

648 textNode (TextNodeConfig initialContents mSetContents) = do

639 textNode (TextNodeConfig initialContents mSetContents) = do

649− liftIO $ putStrLn $ "Text: " <> T.unpack initialContents

650 t <- textNodeInternal initialContents mSetContents

640 t <- textNodeInternal initialContents mSetContents

651 return $ TextNode t

641 return $ TextNode t

652 {-# INLINABLE commentNode #-}

642 {-# INLINABLE commentNode #-}

653 commentNode (CommentNodeConfig initialContents mSetContents) = do

643 commentNode (CommentNodeConfig initialContents mSetContents) = do

654− liftIO $ putStrLn $ "Comment: " <> T.unpack initialContents

655 c <- commentNodeInternal initialContents mSetContents

644 c <- commentNodeInternal initialContents mSetContents

656 return $ CommentNode c

645 return $ CommentNode c

657 {-# INLINABLE element #-}

646 {-# INLINABLE element #-}

658 element elementTag cfg child = do

647 element elementTag cfg child = do

659− liftIO $ putStrLn $ "Element: " <> T.unpack elementTag

660 fst <$> makeElement elementTag cfg child

648 fst <$> makeElement elementTag cfg child

661 {-# INLINABLE inputElement #-}

649 {-# INLINABLE inputElement #-}

662 inputElement cfg = do

650 inputElement cfg = do

663− ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

651+ ((e, _), domElementRef) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

652+

653+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

654+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

655+

656+ (focusChange, triggerFocusChange) <- newTriggerEvent

657+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent

658+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent

659+

660+ -- Expected initial value from config

661+ let v0 = _inputElementConfig_initialValue cfg

662+

663+ addHydrationStep $ do

664+ domElement <- liftIO $ readIORef domElementRef

664− let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

665+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

665− Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue

666+ getValue = Input.getValue domInputElement

666− v0 <- Input.getValue domInputElement

667+

667− let getMyValue = Input.getValue domInputElement

668+ -- The browser might have messed with the value, or the user could have

669+ -- altered it before activation, so we set it if it isn't what we expect

670+ liftJSM getValue >>= \v0' -> do

671+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

672+

673+ -- Watch for user interaction and trigger event accordingly

668− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

674+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

675+

669− valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

676+ case _inputElementConfig_setValue cfg of

670− Nothing -> return never

677+ Nothing -> pure ()

671− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

678+ Just eSetValue -> requestDomAction_ $ ffor eSetValue $ \v' -> do

672− Input.setValue domInputElement v'

679+ Input.setValue domInputElement v'

673− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

680+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

681+ liftIO $ triggerChangeBySetValue v

682+

683+ -- TODO look at initial focus at hydration time?

674− v <- holdDyn v0 $ leftmost

684+ let focusChange' = leftmost

675− [ valueChangedBySetValue

685+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

676− , valueChangedByUI

686+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)

677− ]

687+ ]

688+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

689+

678− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

690+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

679− checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do

691+ liftJSM $ domInputElement `on` Events.click $ do

680− Input.getChecked domInputElement

692+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement

693+

681− checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of

694+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->

682− Nothing -> return never

683− Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do

695+ requestDomAction $ ffor eNewchecked $ \newChecked -> do

684− oldChecked <- Input.getChecked domInputElement

696+ oldChecked <- Input.getChecked domInputElement

685− Input.setChecked domInputElement newChecked

697+ Input.setChecked domInputElement newChecked

686− return $ if newChecked /= oldChecked

698+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked

687− then Just newChecked

699+

688− else Nothing

700+-- files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do

701+-- mfiles <- Input.getFiles domInputElement

702+-- let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

703+-- maybe (return []) getMyFiles mfiles

704+

689− c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

705+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

690− [ fmapMaybe id checkedChangedBySetChecked

706+ [ checkedChangedBySetChecked

691 , checkedChangedByUI

707 , checkedChangedByUI

692 ]

708 ]

709+ checked <- holdUniqDyn checked'

710+

693 let initialFocus = False --TODO: Is this correct?

711 let initialFocus = False --TODO: Is this correct?

694− hasFocus <- holdDyn initialFocus $ leftmost

712+ hasFocus <- holdDyn initialFocus focusChange

695− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

713+

696− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

714+ v <- holdDyn v0 $ leftmost

715+ [ valueChangedBySetValue

716+ , valueChangedByUI

697 ]

717 ]

698− files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do

718+

699− mfiles <- Input.getFiles domInputElement

700− let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

701− maybe (return []) getMyFiles mfiles

702− checked <- holdUniqDyn c

703 return $ InputElement

719 return $ InputElement

704 { _inputElement_value = v

720 { _inputElement_value = v

705 , _inputElement_checked = checked

721 , _inputElement_checked = checked

706− , _inputElement_checkedChange = checkedChangedByUI

722+ , _inputElement_checkedChange = checkedChangedByUI

707 , _inputElement_input = valueChangedByUI

723 , _inputElement_input = valueChangedByUI

708 , _inputElement_hasFocus = hasFocus

724 , _inputElement_hasFocus = hasFocus

709 , _inputElement_element = e

725 , _inputElement_element = e

710− , _inputElement_raw = domInputElement

726+ , _inputElement_raw = undefined -- domInputElement

711− , _inputElement_files = files

727+ , _inputElement_files = undefined -- files

712 }

728 }

729+

713 {-# INLINABLE textAreaElement #-}

730 {-# INLINABLE textAreaElement #-}

714 textAreaElement cfg = do --TODO

731 textAreaElement cfg = do --TODO

715− ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

732+ ((e, _), domElement') <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

733+ let domElement = undefined :: DOM.HTMLTextAreaElement

716 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

734 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

717 TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

735 TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

718 v0 <- TextArea.getValue domTextAreaElement

736 v0 <- TextArea.getValue domTextAreaElement

@@ -737,7 +755,8 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT

737 }

755 }

738 {-# INLINABLE selectElement #-}

756 {-# INLINABLE selectElement #-}

739 selectElement cfg child = do

757 selectElement cfg child = do

740− ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

758+ ((e, result), domElement') <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

759+ let domElement = undefined :: DOM.HTMLSelectElement

741 let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

760 let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

742 Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue

761 Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue

743 v0 <- Select.getValue domSelectElement

762 v0 <- Select.getValue domSelectElement

reflex-dom-core/src/Reflex/Dom/Core.hs+2−1

@@ -2,7 +2,8 @@ module Reflex.Dom.Core (module X) where

3import Reflex as X hiding (askEvents)

4import Reflex.Dom.Builder.Class as X

5−import Reflex.Dom.Builder.Immediate as X

5+import Reflex.Dom.Builder.Hydration as X

6+--import Reflex.Dom.Builder.Immediate as X

6import Reflex.Dom.Builder.InputDisabled as X

7import Reflex.Dom.Builder.InputDisabled as X

7import Reflex.Dom.Builder.Static as X

8import Reflex.Dom.Builder.Static as X

8import Reflex.Dom.Class as X

9import Reflex.Dom.Class as X

reflex-dom-core/src/Reflex/Dom/Main.hs+104

@@ -17,6 +17,8 @@ module Reflex.Dom.Main where

18import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)

20+import Reflex.Adjustable.Class

21+import Reflex.Class

20import Reflex.Dom.Builder.Immediate

22import Reflex.Dom.Builder.Immediate

21import Reflex.Dom.Builder.Hydration

23import Reflex.Dom.Builder.Hydration

22import Reflex.Dom.Class

24import Reflex.Dom.Class

@@ -25,6 +27,8 @@ import Reflex.PerformEvent.Base

25import Reflex.PostBuild.Base

27import Reflex.PostBuild.Base

26import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

28import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

27import Reflex.TriggerEvent.Base

29import Reflex.TriggerEvent.Base

30+import Reflex.TriggerEvent.Class

31+import qualified Reflex.TriggerEvent.Base as TriggerEvent

29import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported

33import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported

@@ -35,6 +39,7 @@ import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence

35import Control.Monad.Ref

39import Control.Monad.Ref

36import Data.ByteString (ByteString)

40import Data.ByteString (ByteString)

37import Data.Dependent.Sum (DSum (..))

41import Data.Dependent.Sum (DSum (..))

42+import Data.Foldable (for_)

38import Data.IORef

43import Data.IORef

39import Data.Maybe

44import Data.Maybe

40import Data.Monoid ((<>))

45import Data.Monoid ((<>))

@@ -53,6 +58,105 @@ import qualified GHCJS.DOM.Types as DOM

53import Reflex.Profiled

58import Reflex.Profiled

54#endif

59#endif

61+{-# INLINE mainHydrationWidget #-}

62+mainHydrationWidget :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

63+mainHydrationWidget = mainHydrationWidget'

64+

65+{-# INLINABLE mainHydrationWidget' #-}

66+-- | Warning: `mainHydrationWidget'` is provided only as performance tweak. It is expected to disappear in future releases.

67+mainHydrationWidget' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

68+mainHydrationWidget' = mainHydrationWidgetWithSwitchoverAction' (pure ())

69+

70+{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}

71+mainHydrationWidgetWithSwitchoverAction :: IO () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

72+mainHydrationWidgetWithSwitchoverAction = mainHydrationWidgetWithSwitchoverAction'

73+

74+{-# INLINABLE mainHydrationWidgetWithSwitchoverAction' #-}

75+-- | Warning: `mainHydrationWidgetWithSwitchoverAction'` is provided only as performance tweak. It is expected to disappear in future releases.

76+mainHydrationWidgetWithSwitchoverAction' :: IO () -> HydrationWidget () () -> HydrationWidget () () -> JSM ()

77+mainHydrationWidgetWithSwitchoverAction' switchoverAction head body = do

78+ runHydrationWidgetWithHeadAndBody switchoverAction $ \appendHead appendBody -> do

79+ appendHead head

80+ appendBody body

81+

82+{-# INLINABLE attachHydrationWidget #-}

83+attachHydrationWidget

84+ :: IO ()

85+ -> IORef HydrationMode

86+ -> IORef [(Node, HydrationRunnerT DomTimeline (PostBuildT DomTimeline (WithJSContextSingleton () (PerformEventT DomTimeline DomHost))) ())]

87+ -> JSContextSingleton ()

88+ -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))

89+ -> IO ()

90+attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do

91+ events <- newChan

92+ runDomHost $ flip runTriggerEventT events $ mdo

93+ (syncEvent, fireSync) <- newTriggerEvent

94+ (postBuildTriggerRef, fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do

95+ a <- w events syncEvent

96+ runWithReplace (return ()) $ delayedAction <$ syncEvent

97+ pure a

98+ mPostBuildTrigger <- readRef postBuildTriggerRef

99+ lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

100+ liftIO $ fireSync ()

101+ rootNodes <- liftIO $ readIORef rootNodesRef

102+ -- TODO: DomHost is SpiderHost Global only if we're not in profiling mode

103+ let delayedAction = do

104+ for_ (reverse rootNodes) $ \(rootNode, runner) -> do

105+ void $ runWithJSContextSingleton (runPostBuildT (runHydrationRunnerT runner Nothing rootNode events) never) jsSing

106+ liftIO $ writeIORef hydrationMode HydrationMode_Immediate

107+ liftIO $ switchoverAction

108+ liftIO $ processAsyncEvents events fc

109+

110+type HydrationWidget x a = HydrationDomBuilderT DomTimeline (DomCoreWidget x) a

111+

112+-- | A widget that isn't attached to any particular part of the DOM hierarchy

113+type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)

114+

115+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))

116+

117+runHydrationWidgetWithHeadAndBody

118+ :: IO ()

119+ -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"

120+ -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"

121+ -> FloatingWidget () ()

122+ )

123+ -> JSM ()

124+runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonMono $ \jsSing -> do

125+ globalDoc <- currentDocumentUnchecked

126+ headElement <- getHeadUnchecked globalDoc

127+ bodyElement <- getBodyUnchecked globalDoc

128+ unreadyChildren <- liftIO $ newIORef 0

129+ hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating

130+ hydrationResult <- liftIO $ newIORef []

131+ liftIO $ attachHydrationWidget switchoverAction hydrationMode hydrationResult jsSing $ \events switchover -> flip runWithJSContextSingleton jsSing $ do

132+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

133+ let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

134+ hydrateDom n w = do

135+ events' <- TriggerEvent.askEvents

136+ parent <- liftIO $ newIORef $ toNode n

137+ lift $ do

138+ let builderEnv = HydrationDomBuilderEnv

139+ { _hydrationDomBuilderEnv_document = globalDoc

140+ , _hydrationDomBuilderEnv_parent = parent

141+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

142+ , _hydrationDomBuilderEnv_commitAction = pure ()

143+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

144+ , _hydrationDomBuilderEnv_switchover = switchover

145+ }

146+ (a, res) <- runHydrationDomBuilderT w builderEnv events'

147+ liftIO $ modifyIORef' hydrationResult ((n, res) :)

148+ pure a

149+ flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)

150+-- liftIO (readIORef unreadyChildren) >>= \case

151+-- 0 -> DOM.liftJSM commit

152+-- _ -> return ()

153+ return postBuildTriggerRef

154+

155+

156+

157+

158+

159+

56{-# INLINE mainWidget #-}

160{-# INLINE mainWidget #-}

57mainWidget :: (forall x. Widget x ()) -> JSM ()

161mainWidget :: (forall x. Widget x ()) -> JSM ()

58mainWidget = mainWidget'

162mainWidget = mainWidget'

reflex-dom-core/test/hydration.hsnew file+393

@@ -0,0 +1,393 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE RecursiveDo #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+

12+import Control.Concurrent

13+import Control.Monad

14+import Control.Monad.Catch

15+import Control.Monad.Fix

16+import Control.Monad.IO.Class

17+import Data.Foldable (traverse_)

18+import Data.IORef

19+import Data.Maybe (fromMaybe)

20+import Data.Proxy

21+import Data.Text (Text)

22+import Language.Javascript.JSaddle (JSException(..), syncPoint)

23+import Language.Javascript.JSaddle.Warp

24+import Network.HTTP.Types (status200)

25+import Network.Wai

26+import Network.WebSockets

27+import Reflex.Dom.Core

28+import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)

29+import System.Random

30+import System.Timeout

31+import Test.Hspec

32+import Test.HUnit

33+import Test.WebDriver (WD)

34+

35+--import System.IO.Silently

36+import System.IO.Temp

37+import System.IO

38+import GHC.IO.Handle (hDuplicate, hDuplicateTo)

39+

40+import qualified Data.ByteString.Lazy as LBS

41+import qualified Data.Text as T

42+import qualified Data.Text.Encoding as TE

43+import qualified Network.Wai.Handler.Warp as Warp

44+import qualified Test.WebDriver as WD

45+

46+testTimeLimit :: Int

47+testTimeLimit = 1 * 1000 * 1000

48+

49+chromeConfig :: WD.WDConfig

50+chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig

51+

52+-- TODO list

53+-- use only available ports

54+-- parallel (requires port fix)

55+

56+main :: IO ()

57+main = hspec $ parallel $ do

58+

59+ describe "text" $ parallel $ do

60+ it "works" $ do

61+ testWidgetStatic (checkBodyText "hello world") $ do

62+ text "hello world"

63+ it "works with postBuild" $ do

64+ testWidgetStatic (checkBodyText "pb") $ do

65+ pb <- getPostBuild

66+ void $ textNode $ TextNodeConfig "" $ Just $ "pb" <$ pb

67+ it "works for adjacent text nodes" $ do

68+ testWidgetStatic (checkBodyText "hello world") $ do

69+ text "hello "

70+ text "world"

71+ it "works for empty adjacent text nodes" $ do

72+ testWidgetStatic (checkBodyText "hello world") $ do

73+ pb <- getPostBuild

74+ text ""

75+ text ""

76+ _ <- textNode $ TextNodeConfig "" $ Just $ "hello " <$ pb

77+ _ <- textNode $ TextNodeConfig "abc" $ Just $ "" <$ pb

78+ _ <- textNode $ TextNodeConfig "" $ Just $ "world" <$ pb

79+ text ""

80+ it "works when empty text nodes are the only children of an element" $ do

81+ testWidgetStatic (checkBodyText "hello world") $ do

82+ el "div" $ do

83+ text ""

84+ text ""

85+ text "hello world"

86+ it "works when an empty text node is the first child before text" $ do

87+ testWidgetStatic (checkTextInTag "div" "hello world") $ do

88+ el "div" $ do

89+ text ""

90+ text "hello world"

91+ it "works when an empty text node is the first child before element" $ do

92+ testWidgetStatic (checkTextInTag "div" "hello world") $ do

93+ el "div" $ do

94+ text ""

95+ el "span" $ text "hello world"

96+ it "works when an empty text node is the last child" $ do

97+ testWidgetStatic (checkTextInTag "div" "hello world") $ do

98+ el "div" $ do

99+ el "span" $ text "hello world"

100+ text ""

101+

102+ it "updates after postBuild" $ do

103+ testWidget (checkBodyText "initial") (checkBodyText "after") $ do

104+ after <- delay 0 =<< getPostBuild

105+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after

106+ it "updates immediately after postBuild" $ do

107+ testWidget (checkBodyText "pb") (checkBodyText "after") $ do

108+ pb <- getPostBuild

109+ after <- delay 0 pb

110+ void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]

111+ it "updates in immediate mode" $ do

112+ let checkUpdated = do

113+ checkBodyText "initial"

114+ WD.click =<< WD.findElem (WD.ByTag "button")

115+ liftIO $ threadDelay 100000 -- wait for update

116+ checkBodyText "after"

117+ testWidget (pure ()) checkUpdated $ prerender (pure ()) $ do

118+ click <- button ""

119+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click

120+

121+ it "works when given differing results of prerender" $ do

122+ testWidgetStatic (pure ()) $ do

123+ text =<< prerender (pure "One") (pure "Two")

124+

125+

126+ describe "element" $ parallel $ do

127+ it "works with domEvent Click" $ do

128+ clickedRef <- newIORef False

129+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do

130+ (e, _) <- el' "div" $ text "hello world"

131+ performEvent_ $ liftIO (writeIORef clickedRef True) <$ domEvent Click e

132+ clicked <- readIORef clickedRef

133+ assertEqual "Not clicked" True clicked

134+ it "works with eventFlags stopPropagation" $ do

135+ firstClickedRef <- newIORef False

136+ secondClickedRef <- newIORef False

137+ let clickBoth = do

138+ WD.findElem (WD.ById "first") >>= WD.click

139+ WD.findElem (WD.ById "second") >>= WD.click

140+ testWidget (pure ()) clickBoth $ do

141+ (firstDivEl, _) <- el' "div" $ prerender (pure ()) $ do

142+ void $ elAttr "span" ("id" =: "first") $ text "hello world"

143+ performEvent_ $ liftIO (writeIORef firstClickedRef True) <$ domEvent Click firstDivEl

144+ (secondDivEl, _) <- el' "div" $ prerender (pure ()) $ do

145+ let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace

146+ conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)

147+ & initialAttributes .~ "id" =: "second"

148+ & elementConfig_eventSpec .~ (addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) def)

149+ void $ element "span" conf $ text "hello world"

150+ performEvent_ $ liftIO (writeIORef secondClickedRef True) <$ domEvent Click secondDivEl

151+ firstClicked <- readIORef firstClickedRef

152+ secondClicked <- readIORef secondClickedRef

153+ assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)

154+ it "works with eventFlags preventDefault" $ do

155+ let click = do

156+ e <- WD.findElem $ WD.ByTag "input"

157+ s0 <- WD.isSelected e

158+ WD.click e

159+ s1 <- WD.isSelected e

160+ pure (s0, s1)

161+ clicked <- testWidget (pure ()) click $ prerender (pure ()) $ do

162+ let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace

163+ conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)

164+ & elementConfig_eventSpec .~ (addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> preventDefault) def)

165+ & initialAttributes .~ "type" =: "checkbox"

166+ void $ element "input" conf $ text "hello world"

167+ assertEqual "Click not prevented" (False, False) clicked

168+

169+ it "can add/update/remove attributes" $ do

170+ let checkInitialAttrs = do

171+ e <- WD.findElem $ WD.ByTag "div"

172+ assertAttr e "const" (Just "const")

173+ assertAttr e "delete" (Just "delete")

174+ assertAttr e "init" (Just "init")

175+ assertAttr e "click" Nothing

176+ pure e

177+ checkModifyAttrs e = do

178+ WD.click e

179+ liftIO $ threadDelay 100000

180+ assertAttr e "const" (Just "const")

181+ assertAttr e "delete" Nothing

182+ assertAttr e "init" (Just "click")

183+ assertAttr e "click" (Just "click")

184+ testWidget' checkInitialAttrs checkModifyAttrs $ mdo

185+ let conf = def

186+ & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"

187+ & modifyAttributes .~ (("delete" =: Nothing <> "init" =: Just "click" <> "click" =: Just "click") <$ click)

188+ (e, ()) <- element "div" conf $ text "hello world"

189+ let click = domEvent Click e

190+ return ()

191+

192+ -- TODO check this is the correct solution

193+ it "has ssr attribute, removes ssr attribute" $ do

194+ let checkSSRAttr = do

195+ e <- WD.findElem $ WD.ByTag "div"

196+ assertAttr e "ssr" (Just "")

197+ pure e

198+ testWidget' checkSSRAttr (\e -> assertAttr e "ssr" Nothing) $ el "div" $ text "hello world"

199+

200+ describe "inputElement" $ parallel $ do

201+ it "doesn't wipe user input when switching over" $ do

202+ inputRef <- newIORef ""

203+ testWidget'

204+ (do

205+ e <- WD.findElem $ WD.ByTag "input"

206+ WD.sendKeys "hello world" e

207+ pure e)

208+ (\e -> do

209+ t <- WD.attr e "value"

210+ liftIO $ t `shouldBe` Just "hello world"

211+ WD.click <=< WD.findElem $ WD.ByTag "button"

212+ input <- liftIO $ readIORef inputRef

213+ liftIO $ input `shouldBe` "hello world"

214+ ) $ do

215+ e <- inputElement def

216+ click <- button "save"

217+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

218+ it "captures user input after switchover" $ do

219+ inputRef <- newIORef ""

220+ let checkValue = do

221+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"

222+ WD.click <=< WD.findElem $ WD.ByTag "button"

223+ input <- liftIO $ readIORef inputRef

224+ liftIO $ input `shouldBe` "hello world"

225+ testWidget (pure ()) checkValue $ do

226+ e <- inputElement def

227+ click <- button "save"

228+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click

229+ it "sets focus appropriately" $ do

230+ focusRef <- newIORef False

231+ let checkValue = do

232+ liftIO $ readIORef focusRef >>= flip shouldBe False

233+ e <- WD.findElem $ WD.ByTag "input"

234+ WD.moveToCenter e

235+ WD.click e

236+ liftIO $ threadDelay 100000

237+ liftIO $ readIORef focusRef >>= flip shouldBe True

238+ testWidget (pure ()) checkValue $ do

239+ e <- inputElement def

240+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)

241+ it "sets checked appropriately" $ do

242+ checkedByUIRef <- newIORef False

243+ checkedRef <- newIORef False

244+ setCheckedChan <- newChan

245+ let checkValue = do

246+ liftIO $ readIORef checkedByUIRef >>= flip shouldBe False

247+ liftIO $ readIORef checkedRef >>= flip shouldBe False

248+ e <- WD.findElem $ WD.ByTag "input"

249+ WD.moveToCenter e

250+ WD.click e

251+ liftIO $ do

252+ threadDelay 100000

253+ readIORef checkedByUIRef >>= flip shouldBe True

254+ readIORef checkedRef >>= flip shouldBe True

255+ writeChan setCheckedChan False

256+ threadDelay 100000

257+ readIORef checkedByUIRef >>= flip shouldBe True

258+ readIORef checkedRef >>= flip shouldBe False

259+ testWidget (pure ()) checkValue $ do

260+ (setChecked, triggerSetChecked) <- newTriggerEvent

261+ liftIO $ triggerSetChecked False

262+ liftIO $ forkIO $ forever $ do

263+ liftIO $ putStrLn "before"

264+ triggerSetChecked =<< readChan setCheckedChan

265+ liftIO $ putStrLn "after"

266+ performEvent_ $ ffor setChecked $ \c -> do

267+ liftIO $ do

268+ putStrLn "---------------setChecked"

269+ print c

270+ e <- inputElement $ def

271+ & initialAttributes .~ "type" =: "checkbox"

272+ & inputElementConfig_setChecked .~ setChecked

273+ performEvent_ $ liftIO . writeIORef checkedByUIRef <$> _inputElement_checkedChange e

274+ performEvent_ $ liftIO . writeIORef checkedRef <$> updated (_inputElement_checked e)

275+

276+ describe "prerender" $ parallel $ do

277+ it "works in simple case" $ do

278+ testWidget (checkBodyText "One") (checkBodyText "Two") $ do

279+ prerender (text "One") (text "Two")

280+ it "removes element correctly" $ do

281+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do

282+ prerender (el "span" $ text "One") (text "Two")

283+ it "can be nested in server widget" $ do

284+ testWidget (checkBodyText "One") (checkBodyText "Three") $ do

285+ prerender (prerender (text "One") (text "Two")) (text "Three")

286+ it "can be nested in client widget" $ do

287+ testWidget (checkBodyText "One") (checkBodyText "Three") $ do

288+ prerender (text "One") (prerender (text "Two") (text "Three"))

289+ it "works with prerender siblings" $ do

290+ testWidget

291+ (checkTextInId "a1" "One" >> checkTextInId "b1" "Three" >> checkTextInId "c1" "Five")

292+ (checkTextInId "a2" "Two" >> checkTextInId "b2" "Four" >> checkTextInId "c2" "Six") $ do

293+ prerender (divId "a1" $ text "One") (divId "a2" $ text "Two")

294+ prerender (divId "b1" $ text "Three") (divId "b2" $ text "Four")

295+ prerender (divId "c1" $ text "Five") (divId "c2" $ text "Six")

296+ it "works inside other element" $ do

297+ testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do

298+ el "div" $ prerender (text "One") (text "Two")

299+

300+ it "places fences and removes them" $ do

301+ testWidget'

302+ (do

303+ scripts <- WD.findElems $ WD.ByTag "script"

304+ filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts

305+ )

306+ (traverse_ elementShouldBeRemoved)

307+ (el "span" $ prerender (text "One") (text "Two"))

308+

309+assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()

310+assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k

311+

312+elementShouldBeRemoved :: WD.Element -> WD ()

313+elementShouldBeRemoved e = do

314+ try (WD.getText e) >>= \case

315+ Left (WD.FailedCommand WD.StaleElementReference _) -> return ()

316+ Left e -> throwM e

317+ Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"

318+

319+shouldContainText :: WD.Element -> Text -> WD ()

320+shouldContainText e t = liftIO . flip shouldBe t =<< WD.getText e

321+

322+checkBodyText :: Text -> WD ()

323+checkBodyText = checkTextInTag "body"

324+

325+checkTextInTag :: Text -> Text -> WD ()

326+checkTextInTag tag expected = do

327+ body <- WD.findElem $ WD.ByTag tag

328+ body `shouldContainText` expected

329+

330+checkTextInId :: Text -> Text -> WD ()

331+checkTextInId i expected = do

332+ e <- WD.findElem $ WD.ById i

333+ e `shouldContainText` expected

334+

335+divId :: DomBuilder t m => Text -> m a -> m a

336+divId i = elAttr "div" ("id" =: i)

337+

338+type TestWidget js t m = (DomBuilder t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m, MonadIO m)

339+

340+testWidgetStatic

341+ :: WD b

342+ -- ^ Webdriver commands to run before JS runs and after hydration switchover

343+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

344+ -- ^ Widget we are testing

345+ -> IO b

346+testWidgetStatic w = testWidget (void w) w

347+

348+-- | TODO: do something about JSExceptions not causing tests to fail

349+testWidget

350+ :: WD ()

351+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

352+ -> WD b

353+ -- ^ Webdriver commands to run after hydration switchover

354+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

355+ -- ^ Widget we are testing

356+ -> IO b

357+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)

358+

359+-- | TODO: do something about JSExceptions not causing tests to fail

360+testWidget'

361+ :: WD a

362+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)

363+ -> (a -> WD b)

364+ -- ^ Webdriver commands to run after hydration switchover

365+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())

366+ -- ^ Widget we are testing (contents of body)

367+ -> IO b

368+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do

369+ let staticApp = do

370+ el "head" $ pure ()

371+ el "body" $ do

372+ bodyWidget

373+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False

374+ ((), html) <- renderStatic staticApp

375+ waitBeforeJS <- newEmptyMVar -- Empty until JS should be run

376+ waitUntilSwitchover <- newEmptyMVar -- Empty until switchover

377+ let entryPoint = do

378+ liftIO $ takeMVar waitBeforeJS

379+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) $ bodyWidget

380+ syncPoint

381+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html

382+ --port <- randomRIO (3000, 50000)

383+ let port = 3911 -- TODO

384+ let settings = Warp.setPort port Warp.defaultSettings

385+ -- hSilence to get rid of ConnectionClosed logs

386+ jsaddleWarp = forkIO $ Warp.runSettings settings application

387+ bracket jsaddleWarp killThread $ \_ -> do

388+ WD.runSession chromeConfig . WD.finallyClose $ do

389+ WD.openPage $ "http://localhost:" <> show port

390+ a <- beforeJS

391+ liftIO $ putMVar waitBeforeJS ()

392+ liftIO $ takeMVar waitUntilSwitchover

393+ afterSwitchover a