@@ -34,6 +34,7 @@ import Data.Text (Text)
3434import Language.Javascript.JSaddle (syncPoint, liftJSM)
3535import Language.Javascript.JSaddle.Warp
3636import Network.HTTP.Types (status200)
37+import Network.Socket
3738import Network.Wai
3839import Network.WebSockets
3940import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
@@ -45,7 +46,7 @@ import System.IO.Temp
4546import System.Process
4647import System.Timeout
4748import Test.HUnit (assertEqual, assertFailure)
48−import Test.Hspec (hspec, it, describe, beforeAll, shouldBe)
49+import Test.Hspec (Spec, parallel, hspec, it, describe, shouldBe)
4950import Test.WebDriver (WD)
5051
5152import qualified Data.ByteString.Lazy as LBS
@@ -60,8 +61,8 @@ import qualified Test.WebDriver as WD
6061testTimeLimit :: Int
6162testTimeLimit = 5 * 1000 * 1000
6263
63−chromeConfig :: WD.WDConfig
64−chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig
64+chromeConfig :: Text -> WD.WDConfig
65+chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
6566
6667keyMap :: DMap DKey Identity
6768keyMap = DMap.fromList
@@ -105,8 +106,11 @@ instance EqTag DKey Identity where
105106 eqTagged Key_Bool Key_Bool = (==)
106107
107108main :: IO ()
108−main = hspec $ beforeAll startSeleniumServer $ do
109+main = withSeleniumServer $ \selenium ->
110+ hspec (parallel (tests selenium)) `finally` _selenium_stopServer selenium
109111
112+tests :: Selenium -> Spec
113+tests _selenium = do
110114 describe "text" $ do
111115 it "works" $ do
112116 testWidgetStatic (checkBodyText "hello world") $ do
@@ -1003,15 +1007,29 @@ main = hspec $ beforeAll startSeleniumServer $ do
10031007 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
10041008 liftIO $ dmap `shouldBe` keyMap
10051009
1006−startSeleniumServer :: IO ()
1007−startSeleniumServer = do
1008− (_,_,_,ph) <- createProcess $ (proc "selenium-server" [])
1010+data Selenium = Selenium
1011+ { _selenium_portNumber :: PortNumber
1012+ , _selenium_stopServer :: IO ()
1013+ }
1014+
1015+startSeleniumServer :: PortNumber -> IO (IO ())
1016+startSeleniumServer port = do
1017+ (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
10091018 { std_in = NoStream
10101019 , std_out = NoStream
10111020 , std_err = NoStream
10121021 }
1013− _ <- forkIO $ print =<< waitForProcess ph
1022+ return $ terminateProcess ph
1023+
1024+withSeleniumServer :: (Selenium -> IO ()) -> IO ()
1025+withSeleniumServer f = do
1026+ let port = 4444 -- TODO port <- getFreePort
1027+ stopServer <- startSeleniumServer port
10141028 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1029+ f $ Selenium
1030+ { _selenium_portNumber = port
1031+ , _selenium_stopServer = stopServer
1032+ }
10151033
10161034triggerEventWithChan :: (Reflex t, TriggerEvent t m, Prerender t m) => Chan a -> m (Event t a)
10171035triggerEventWithChan chan = do
@@ -1088,13 +1106,14 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
10881106 mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) $ bodyWidget
10891107 syncPoint
10901108 application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1091− --port <- randomRIO (3000, 50000)
1092− let port = 3911 -- TODO
1093− let settings = Warp.setPort port Warp.defaultSettings
1109+ port <- getFreePort
1110+ let settings = Warp.setPort (fromIntegral $ toInteger port) Warp.defaultSettings
10941111 -- hSilence to get rid of ConnectionClosed logs
10951112 jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
10961113 bracket jsaddleWarp killThread $ \_ -> do
1097− WD.runSession chromeConfig . WD.finallyClose $ do
1114+ browserPath <- T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
1115+ when (T.null browserPath) $ fail "No browser was found"
1116+ WD.runSession (chromeConfig browserPath) . WD.finallyClose $ do
10981117 WD.openPage $ "http://localhost:" <> show port
10991118 a <- beforeJS
11001119 liftIO $ putMVar waitBeforeJS ()
@@ -1102,6 +1121,17 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
11021121 liftIO $ threadDelay 100000 -- wait a bit
11031122 afterSwitchover a
11041123
1124+-- TODO: Should this be part of more widely used module?
1125+getFreePort :: MonadIO m => m PortNumber
1126+getFreePort = liftIO $ withSocketsDo $ do
1127+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1128+ bracket (open addr) close socketPort
1129+ where
1130+ open addr = do
1131+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1132+ bind sock (addrAddress addr)
1133+ return sock
1134+
11051135testWidgetDebug :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> IO ()
11061136testWidgetDebug bodyWidget = do
11071137 let staticApp = do