@@ -1,13 +1,9 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
21{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE UndecidableInstances #-}
62{-# LANGUAGE ConstraintKinds #-}
7−{-# LANGUAGE CPP #-}
83{-# LANGUAGE FlexibleContexts #-}
94{-# LANGUAGE FlexibleInstances #-}
105{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
117{-# LANGUAGE LambdaCase #-}
128{-# LANGUAGE MultiParamTypeClasses #-}
139{-# LANGUAGE OverloadedStrings #-}
@@ -15,13 +11,18 @@
1511{-# LANGUAGE RankNTypes #-}
1612{-# LANGUAGE RecursiveDo #-}
1713{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
1815{-# LANGUAGE TemplateHaskell #-}
1916{-# LANGUAGE TupleSections #-}
2017{-# LANGUAGE TypeApplications #-}
2118{-# LANGUAGE TypeFamilies #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+
21+{-# OPTIONS_GHC -fno-warn-orphans #-}
2222
2323import Prelude hiding (fail)
2424import Control.Concurrent
25+import qualified Control.Concurrent.Async as Async
2526import Control.Lens.Operators
2627import Control.Monad hiding (fail)
2728import Control.Monad.Catch
@@ -32,7 +33,7 @@ import Control.Monad.Ref
3233import Data.Constraint.Extras
3334import Data.Constraint.Extras.TH
3435import Data.Dependent.Map (DMap)
35−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
36+import Data.Dependent.Sum (DSum(..), (==>))
3637import Data.Functor.Identity
3738import Data.Functor.Misc
3839import Data.GADT.Compare.TH
@@ -63,7 +64,6 @@ import Test.Hspec (xit)
6364import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
6465import qualified Test.Hspec.WebDriver as WD
6566import Test.WebDriver (WD(..))
66−import Test.WebDriver.Exceptions (ServerError(..))
6767
6868import qualified Data.ByteString.Lazy as LBS
6969import qualified Data.Dependent.Map as DMap
@@ -79,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD
7979import Test.Util.ChromeFlags
8080import Test.Util.UnshareNetwork
8181
82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
83+deriving instance MonadMask WD
84+
8285chromium :: FilePath
8386chromium = $(staticWhich "chromium")
8487
@@ -924,6 +927,58 @@ tests withDebugging wdConfig caps _selenium = do
924927 , el "span" . text <$> replace
925928 ]
926929
930+ let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
931+ it "removes bracketing comments" $ runWD $ do
932+ replaceChan :: Chan () <- liftIO newChan
933+ let
934+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
935+ check () = do
936+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
937+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
938+ checkInnerHtml "div" "before|<p>inner2</p>|after"
939+ testWidget' preSwitchover check $ do
940+ replace <- triggerEventWithChan replaceChan
941+ el "div" $ do
942+ text "before|"
943+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
944+ text "|after"
945+ it "ignores extra ending bracketing comment" $ runWD $ do
946+ replaceChan :: Chan () <- liftIO newChan
947+ let
948+ preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
949+ check () = do
950+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
951+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
952+ checkInnerHtml "div" "before|inner2|after"
953+ testWidget' preSwitchover check $ do
954+ replace <- triggerEventWithChan replaceChan
955+ el "div" $ do
956+ text "before|"
957+ _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
958+ text "|after"
959+ void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
960+ it "ignores missing ending bracketing comments" $ runWD $ do
961+ replaceChan :: Chan () <- liftIO newChan
962+ let
963+ preSwitchover = do
964+ checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
965+ divEl <- findElemWithRetry (WD.ByTag "div")
966+ let wrongHtml = "<!--replace-start-0-->inner1"
967+ actualHtml :: String <- WD.executeJS
968+ [WD.JSArg divEl, WD.JSArg wrongHtml]
969+ "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
970+ actualHtml `shouldBe` wrongHtml
971+ check () = do
972+ liftIO $ writeChan replaceChan () -- trigger creation of p tag
973+ _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
974+ checkInnerHtml "div" "before|<p>inner2</p>|after"
975+ testWidget' preSwitchover check $ do
976+ replace <- triggerEventWithChan replaceChan
977+ el "div" $ do
978+ text "before|"
979+ _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
980+ text "|after"
981+
927982 describe "traverseDMapWithKeyWithAdjust" $ session' $ do
928983 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
929984 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
@@ -1315,8 +1370,8 @@ withRetry a = wait 300
13151370 where wait :: Int -> WD a
13161371 wait 0 = a
13171372 wait n = try a >>= \case
1318− Left (_ :: SomeException) -> do
1319− liftIO $ threadDelay 100000
1373+ Left (e :: SomeException) -> do
1374+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
13201375 wait $ n - 1
13211376 Right v -> return v
13221377
@@ -1398,23 +1453,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
13981453 ]
13991454 -- hSilence to get rid of ConnectionClosed logs
14001455 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1401− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1402− jsaddleTid <- liftIO jsaddleWarp
1403− putStrLnDebug "taking waitJSaddle"
1404− liftIO $ takeMVar waitJSaddle
1405− putStrLnDebug "opening page"
1406− WD.openPage $ "http://localhost:" <> show jsaddlePort
1407− putStrLnDebug "running beforeJS"
1408− a <- beforeJS
1409− putStrLnDebug "putting waitBeforeJS"
1410− liftIO $ putMVar waitBeforeJS ()
1411− putStrLnDebug "taking waitUntilSwitchover"
1412− liftIO $ takeMVar waitUntilSwitchover
1413− putStrLnDebug "running afterSwitchover"
1414− b <- afterSwitchover a
1415− putStrLnDebug "killing jsaddle thread"
1416− liftIO $ killThread jsaddleTid
1417− return b
1456+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1457+ withAsync' jsaddleWarp $ do
1458+ putStrLnDebug "taking waitJSaddle"
1459+ liftIO $ takeMVar waitJSaddle
1460+ putStrLnDebug "opening page"
1461+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1462+ putStrLnDebug "running beforeJS"
1463+ a <- beforeJS
1464+ putStrLnDebug "putting waitBeforeJS"
1465+ liftIO $ putMVar waitBeforeJS ()
1466+ putStrLnDebug "taking waitUntilSwitchover"
1467+ liftIO $ takeMVar waitUntilSwitchover
1468+ putStrLnDebug "running afterSwitchover"
1469+ afterSwitchover a
1470+
1471+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1472+withAsync' f g = bracket
1473+ (liftIO $ Async.async f)
1474+ (liftIO . Async.uninterruptibleCancel)
1475+ (const g)
14181476
14191477data Key2 a where
14201478 Key2_Int :: Int -> Key2 Int