@@ -22,6 +22,7 @@
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
@@ -78,6 +79,9 @@ import qualified Test.WebDriver.Capabilities as WD
7879import Test.Util.ChromeFlags
7980import Test.Util.UnshareNetwork
8081
82+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
83+deriving instance MonadMask WD
84+
8185chromium :: FilePath
8286chromium = $(staticWhich "chromium")
8387
@@ -1397,23 +1401,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
13971401 ]
13981402 -- hSilence to get rid of ConnectionClosed logs
13991403 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1400− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1401− jsaddleTid <- liftIO jsaddleWarp
1402− putStrLnDebug "taking waitJSaddle"
1403− liftIO $ takeMVar waitJSaddle
1404− putStrLnDebug "opening page"
1405− WD.openPage $ "http://localhost:" <> show jsaddlePort
1406− putStrLnDebug "running beforeJS"
1407− a <- beforeJS
1408− putStrLnDebug "putting waitBeforeJS"
1409− liftIO $ putMVar waitBeforeJS ()
1410− putStrLnDebug "taking waitUntilSwitchover"
1411− liftIO $ takeMVar waitUntilSwitchover
1412− putStrLnDebug "running afterSwitchover"
1413− b <- afterSwitchover a
1414− putStrLnDebug "killing jsaddle thread"
1415− liftIO $ killThread jsaddleTid
1416− return b
1404+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1405+ withAsync' jsaddleWarp $ do
1406+ putStrLnDebug "taking waitJSaddle"
1407+ liftIO $ takeMVar waitJSaddle
1408+ putStrLnDebug "opening page"
1409+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1410+ putStrLnDebug "running beforeJS"
1411+ a <- beforeJS
1412+ putStrLnDebug "putting waitBeforeJS"
1413+ liftIO $ putMVar waitBeforeJS ()
1414+ putStrLnDebug "taking waitUntilSwitchover"
1415+ liftIO $ takeMVar waitUntilSwitchover
1416+ putStrLnDebug "running afterSwitchover"
1417+ afterSwitchover a
1418+
1419+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1420+withAsync' f g = bracket
1421+ (liftIO $ Async.async f)
1422+ (liftIO . Async.uninterruptibleCancel)
1423+ (const g)
14171424
14181425data Key2 a where
14191426 Key2_Int :: Int -> Key2 Int