@@ -20,9 +20,11 @@
20{-# LANGUAGE TypeApplications #-}
20{-# LANGUAGE TypeApplications #-}
21{-# LANGUAGE TypeFamilies #-}
21{-# LANGUAGE TypeFamilies #-}
23+import Prelude hiding (fail)
23import Control.Concurrent
24import Control.Concurrent
24−import Control.Monad
25+import Control.Monad hiding (fail)
25import Control.Monad.Catch
26import Control.Monad.Catch
27+import Control.Monad.Fail
26import Control.Monad.Fix
28import Control.Monad.Fix
27import Control.Monad.IO.Class
29import Control.Monad.IO.Class
28import Control.Monad.Ref
30import Control.Monad.Ref
@@ -59,6 +61,7 @@ import Test.Hspec (xit)
59import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
61import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
60import qualified Test.Hspec.WebDriver as WD
62import qualified Test.Hspec.WebDriver as WD
61import Test.WebDriver (WD(..))
63import Test.WebDriver (WD(..))
64+import Test.WebDriver.Exceptions (ServerError(..))
63import qualified Data.ByteString.Lazy as LBS
66import qualified Data.ByteString.Lazy as LBS
64import qualified Data.Dependent.Map as DMap
67import qualified Data.Dependent.Map as DMap
@@ -117,6 +120,8 @@ deriveGEq ''DKey
117deriveGCompare ''DKey
120deriveGCompare ''DKey
118deriveGShow ''DKey
121deriveGShow ''DKey
123+deriving instance MonadFail WD
120main :: IO ()
125main :: IO ()
122 unshareNetork
127 unshareNetork
@@ -737,9 +742,9 @@ tests withDebugging wdConfig caps _selenium = do
737 pb <- getPostBuild
742 pb <- getPostBuild
738 performEvent_ $ liftIO (putMVar lock ()) <$ pb
743 performEvent_ $ liftIO (putMVar lock ()) <$ pb
739 it "result Dynamic is updated *after* switchover" $ runWD $ do
744 it "result Dynamic is updated *after* switchover" $ runWD $ do
740− let static = checkBodyText "PostBuild"
745+ let preSwitchover = checkBodyText "PostBuild"
741 check = checkBodyText "Client"
746 check = checkBodyText "Client"
742− testWidget static check $ void $ do
747+ testWidget preSwitchover check $ void $ do
743 d <- prerender (pure "Initial") (pure "Client")
748 d <- prerender (pure "Initial") (pure "Client")
744 pb <- getPostBuild
749 pb <- getPostBuild
745 initial <- sample $ current d
750 initial <- sample $ current d
@@ -747,16 +752,16 @@ tests withDebugging wdConfig caps _selenium = do
747 -- This essentially checks that the client IO runs *after* switchover/postBuild,
752 -- This essentially checks that the client IO runs *after* switchover/postBuild,
748 -- thus can't create conflicting DOM
753 -- thus can't create conflicting DOM
749 it "can't exploit IO to break hydration" $ runWD $ do
754 it "can't exploit IO to break hydration" $ runWD $ do
750− let static = checkBodyText "Initial"
755+ let preSwitchover = checkBodyText "Initial"
751− testWidgetStatic static $ void $ do
756+ testWidgetStatic preSwitchover $ void $ do
752 ref <- liftIO $ newRef "Initial"
757 ref <- liftIO $ newRef "Initial"
753 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
758 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
754 text <=< liftIO $ readRef ref
759 text <=< liftIO $ readRef ref
755 -- As above, so below
760 -- As above, so below
756 it "can't exploit triggerEvent to break hydration" $ runWD $ do
761 it "can't exploit triggerEvent to break hydration" $ runWD $ do
757− let static = checkBodyText "Initial"
762+ let preSwitchover = checkBodyText "Initial"
758 check = checkBodyText "Client"
763 check = checkBodyText "Client"
759− testWidget static check $ void $ do
764+ testWidget preSwitchover check $ void $ do
760 (e, trigger) <- newTriggerEvent
765 (e, trigger) <- newTriggerEvent
761 prerender_ (pure ()) (liftIO $ trigger "Client")
766 prerender_ (pure ()) (liftIO $ trigger "Client")
762 textNode $ TextNodeConfig "Initial" $ Just e
767 textNode $ TextNodeConfig "Initial" $ Just e
@@ -945,26 +950,26 @@ tests withDebugging wdConfig caps _selenium = do
945 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
950 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
946 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
951 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
947 chan <- liftIO newChan
952 chan <- liftIO newChan
948− let static :: WD [WD.Element]
953+ let preSwitchover :: WD [WD.Element]
949− static = getAndCheckInitialItems keyMap
954+ preSwitchover = getAndCheckInitialItems keyMap
950 check :: [WD.Element] -> WD ()
955 check :: [WD.Element] -> WD ()
951 check xs = do
956 check xs = do
952 checkInitialItems keyMap xs
957 checkInitialItems keyMap xs
953 checkRemoval chan Key_Int
958 checkRemoval chan Key_Int
954 checkReplace chan Key_Char 'B'
959 checkReplace chan Key_Char 'B'
955 checkInsert chan Key_Bool True
960 checkInsert chan Key_Bool True
956− testWidget' static check $ do
961+ testWidget' preSwitchover check $ do
957 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
962 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
958 liftIO $ dmap `H.shouldBe` keyMap
963 liftIO $ dmap `H.shouldBe` keyMap
959 it "handles postBuild correctly" $ runWD $ do
964 it "handles postBuild correctly" $ runWD $ do
960 chan <- liftIO newChan
965 chan <- liftIO newChan
961− let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
966+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
962 check xs = do
967 check xs = do
963 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
968 withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
964 checkRemoval chan Key_Int
969 checkRemoval chan Key_Int
965 checkInsert chan Key_Char 'B'
970 checkInsert chan Key_Char 'B'
966 checkReplace chan Key_Bool True
971 checkReplace chan Key_Bool True
967− testWidget' static check $ void $ do
972+ testWidget' preSwitchover check $ void $ do
968 pb <- getPostBuild
973 pb <- getPostBuild
969 replace <- triggerEventWithChan chan
974 replace <- triggerEventWithChan chan
970 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
975 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1054,24 +1059,24 @@ tests withDebugging wdConfig caps _selenium = do
1054 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1059 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1055 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1060 xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1056 chan <- liftIO newChan
1061 chan <- liftIO newChan
1057− let static = getAndCheckInitialItems intMap
1062+ let preSwitchover = getAndCheckInitialItems intMap
1058 check xs = do
1063 check xs = do
1059 checkInitialItems intMap xs
1064 checkInitialItems intMap xs
1060 checkRemoval chan 1
1065 checkRemoval chan 1
1061 checkReplace chan 2 "deux"
1066 checkReplace chan 2 "deux"
1062 checkInsert chan 4 "four"
1067 checkInsert chan 4 "four"
1063− testWidget' static check $ void $ do
1068+ testWidget' preSwitchover check $ void $ do
1064 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1069 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1065 liftIO $ im `H.shouldBe` intMap
1070 liftIO $ im `H.shouldBe` intMap
1066 xit "handles postBuild correctly" $ runWD $ do
1071 xit "handles postBuild correctly" $ runWD $ do
1067 chan <- liftIO newChan
1072 chan <- liftIO newChan
1068− let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1073+ let preSwitchover = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1069 check xs = do
1074 check xs = do
1070 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1075 withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1071 checkRemoval chan 1
1076 checkRemoval chan 1
1072 checkInsert chan 2 "deux"
1077 checkInsert chan 2 "deux"
1073 checkReplace chan 3 "trois"
1078 checkReplace chan 3 "trois"
1074− testWidget' static check $ void $ do
1079+ testWidget' preSwitchover check $ void $ do
1075 pb <- getPostBuild
1080 pb <- getPostBuild
1076 replace <- triggerEventWithChan chan
1081 replace <- triggerEventWithChan chan
1077 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1082 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
@@ -1166,12 +1171,12 @@ tests withDebugging wdConfig caps _selenium = do
1167 describe "hydration" $ moveSpec $ \initMap test -> do
1172 describe "hydration" $ moveSpec $ \initMap test -> do
1168 chan <- liftIO newChan
1173 chan <- liftIO newChan
1169− let static = getAndCheckInitialItems initMap
1174+ let preSwitchover = getAndCheckInitialItems initMap
1170 check xs = do
1175 check xs = do
1171 checkInitialItems initMap xs
1176 checkInitialItems initMap xs
1172 body <- getBody
1177 body <- getBody
1173 test body chan
1178 test body chan
1174− testWidget' static check $ void $ do
1179+ testWidget' preSwitchover check $ void $ do
1175 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1180 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1176 liftIO $ assertEqual "DMap" initMap dmap
1181 liftIO $ assertEqual "DMap" initMap dmap
@@ -1197,7 +1202,7 @@ tests withDebugging wdConfig caps _selenium = do
1198 describe "hydrating invalid HTML" $ session' $ do
1203 describe "hydrating invalid HTML" $ session' $ do
1199 it "can hydrate list in paragraph" $ runWD $ do
1204 it "can hydrate list in paragraph" $ runWD $ do
1200− let static = do
1205+ let preSwitchover = do
1201 checkBodyText "before\ninner\nafter"
1206 checkBodyText "before\ninner\nafter"
1202 -- Two <p> tags should be present
1207 -- Two <p> tags should be present
1203 [p1, p2] <- WD.findElems (WD.ByTag "p")
1208 [p1, p2] <- WD.findElems (WD.ByTag "p")
@@ -1211,7 +1216,7 @@ tests withDebugging wdConfig caps _selenium = do
1211 shouldContainText "before\ninner\nafter" p1
1216 shouldContainText "before\ninner\nafter" p1
1212 elementShouldBeRemoved ol
1217 elementShouldBeRemoved ol
1213 elementShouldBeRemoved p2
1218 elementShouldBeRemoved p2
1214− testWidget' static check $ do
1219+ testWidget' preSwitchover check $ do
1215 -- This is deliberately invalid HTML, the browser will interpret it as
1220 -- This is deliberately invalid HTML, the browser will interpret it as
1216 -- <p>before</p><ol>inner</ol>after<p></p>
1221 -- <p>before</p><ol>inner</ol>after<p></p>
1217 el "p" $ do
1222 el "p" $ do
@@ -1344,9 +1349,9 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1344 el "body" $ do
1349 el "body" $ do
1345 bodyWidget
1350 bodyWidget
1346 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1351 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1347− putStrLnDebug "rendering static"
1352+ putStrLnDebug "rendering preSwitchover"
1348 ((), html) <- liftIO $ renderStatic staticApp
1353 ((), html) <- liftIO $ renderStatic staticApp
1349− putStrLnDebug "rendered static"
1354+ putStrLnDebug "rendered preSwitchover"
1350 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1355 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1351 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1356 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1352 let entryPoint = do
1357 let entryPoint = do