git.iko.soy/reflex-dom
on develop help sign in
Fix exception safety bug in hydration tests
ec6f8e4Elliot Cameron
reflex-dom-core/reflex-dom-core.cabal+1
compare with develop
unifiedsplit
@@ -166,6 +166,7 @@ test-suite hlint
166test-suite hydration
166test-suite hydration
167 build-depends: base
167 build-depends: base
168 , aeson
168 , aeson
169+ , async
169 , bytestring
170 , bytestring
170 , chrome-test-utils
171 , chrome-test-utils
171 , constraints
172 , constraints
reflex-dom-core/test/hydration.hs+24−17
@@ -22,6 +22,7 @@
22
22
23import Prelude hiding (fail)
23import Prelude hiding (fail)
24import Control.Concurrent
24import Control.Concurrent
25+import qualified Control.Concurrent.Async as Async
25import Control.Lens.Operators
26import Control.Lens.Operators
26import Control.Monad hiding (fail)
27import Control.Monad hiding (fail)
27import Control.Monad.Catch
28import Control.Monad.Catch
@@ -78,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD
78import Test.Util.ChromeFlags
79import Test.Util.ChromeFlags
79import Test.Util.UnshareNetwork
80import Test.Util.UnshareNetwork
80
81
82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
83+deriving instance MonadMask WD
84+
81chromium :: FilePath
85chromium :: FilePath
82chromium = $(staticWhich "chromium")
86chromium = $(staticWhich "chromium")
83
87
@@ -1397,23 +1401,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1397 ]
1401 ]
1398 -- hSilence to get rid of ConnectionClosed logs
1402 -- hSilence to get rid of ConnectionClosed logs
1399 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1403 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1400− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1404+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1401− jsaddleTid <- liftIO jsaddleWarp
1405+ withAsync' jsaddleWarp $ do
1402− putStrLnDebug "taking waitJSaddle"
1406+ putStrLnDebug "taking waitJSaddle"
1403− liftIO $ takeMVar waitJSaddle
1407+ liftIO $ takeMVar waitJSaddle
1404− putStrLnDebug "opening page"
1408+ putStrLnDebug "opening page"
1405− WD.openPage $ "http://localhost:" <> show jsaddlePort
1409+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1406− putStrLnDebug "running beforeJS"
1410+ putStrLnDebug "running beforeJS"
1407− a <- beforeJS
1411+ a <- beforeJS
1408− putStrLnDebug "putting waitBeforeJS"
1412+ putStrLnDebug "putting waitBeforeJS"
1409− liftIO $ putMVar waitBeforeJS ()
1413+ liftIO $ putMVar waitBeforeJS ()
1410− putStrLnDebug "taking waitUntilSwitchover"
1414+ putStrLnDebug "taking waitUntilSwitchover"
1411− liftIO $ takeMVar waitUntilSwitchover
1415+ liftIO $ takeMVar waitUntilSwitchover
1412− putStrLnDebug "running afterSwitchover"
1416+ putStrLnDebug "running afterSwitchover"
1413− b <- afterSwitchover a
1417+ afterSwitchover a
1414− putStrLnDebug "killing jsaddle thread"
1418+
1415− liftIO $ killThread jsaddleTid
1419+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1416− return b
1420+withAsync' f g = bracket
1421+ (liftIO $ Async.async f)
1422+ (liftIO . Async.uninterruptibleCancel)
1423+ (const g)
1417
1424
1418data Key2 a where
1425data Key2 a where
1419 Key2_Int :: Int -> Key2 Int
1426 Key2_Int :: Int -> Key2 Int