@@ -9,16 +9,24 @@
99
1010{-# OPTIONS_GHC -fno-warn-orphans #-}
1111
12−module Reflex.Dom.Test.Screenshot
12+-- | Utilities for testing reflex-dom widgets with Selenium.
13+--
14+-- Any uses of the 'testWidget' functions will start a jsaddle warp server and
15+-- serve the given widget in an otherwise empty page. Webdriver commands can run
16+-- on the statically rendered page, and on the hydrated page.
17+module Reflex.Dom.Test.Selenium
1318 ( TestWidget
1419 , TestWidgetConfig (..)
1520 , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
16− , testWithSelenium
21+ , withSeleniumSpec
22+ , embedSpec
23+ , SeleniumSetupConfig (..)
1724 ) where
1825
1926import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
20−import Control.Monad (when, void)
21−import Control.Monad.Catch (MonadMask, handle, finally)
27+import Control.Exception (throwIO)
28+import Control.Monad (when)
29+import Control.Monad.Catch (MonadMask, handle)
2230import Control.Monad.Fix (MonadFix)
2331import Control.Monad.IO.Class (MonadIO, liftIO)
2432import Data.Text (Text)
@@ -32,49 +40,47 @@ import Reflex.Dom.Core
3240import System.IO (stderr)
3341import System.IO.Silently (hSilence)
3442import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
35−import qualified Data.Text as T
43+import Test.Hspec.WebDriver (Spec, SpecWith, WdTestSession, sessionWith, using)
44+import Test.Util.ChromeFlags
45+import Test.Util.UnshareNetwork
46+import Test.WebDriver (WD)
3647
3748import qualified Control.Concurrent.Async as Async
38−import qualified Data.Text.Encoding as TE
3949import qualified Data.ByteString.Lazy as LBS
50+import qualified Data.Text as T
51+import qualified Data.Text.Encoding as TE
4052import qualified Network.Wai.Handler.Warp as Warp
41−
42−import Test.Hspec.WebDriver (SpecWith, WdTestSession, hspec, sessionWith, using)
43−import Test.Util.ChromeFlags
44−import Test.Util.UnshareNetwork
45−import Test.WebDriver (WD)
53+import qualified Test.Hspec.Core.Spec as Hspec
4654import qualified Test.WebDriver as WD
4755import qualified Test.WebDriver.Capabilities as WD
4856
4957deriving instance MonadMask WD
5058
51−testWithSelenium
52− :: FilePath
59+data SeleniumSetupConfig = SeleniumSetupConfig
60+ { _seleniumSetupConfig_chromiumPath :: FilePath
5361 -- ^ Path to the chromium executable
54− -> Bool
62+ , _seleniumSetupConfig_headless :: Bool
5563 -- ^ True means that the browser is invoked in headless mode, False means that
5664 -- the user can see the interaction happening on the browser (useful for debugging).
57− -> SpecWith (WdTestSession a)
58− -- ^ The tests we want to write in the selenium session
59− -> IO ()
60−testWithSelenium chromium isHeadless actualTests = do
61− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
62− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
63− withSeleniumServer $ \selenium -> do
64− let browserPath = T.strip $ T.pack chromium
65+ , _seleniumSetupConfig_seleniumPort :: PortNumber
66+ -- ^ The port number used by selenium
67+ }
68+
69+-- | Setup a selenium server and use it to run some hspec tests.
70+--
71+-- withSeleniumSpec config $ \runSession -> hspec $ do
72+-- describe "tests using webdriver session" $ runSession $ do
73+-- webdriver tests here
74+withSeleniumSpec :: SeleniumSetupConfig -> ((forall multi. SpecWith (WdTestSession multi) -> Spec) -> IO a) -> IO a
75+withSeleniumSpec config runSpec = do
76+ liftIO $ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
77+ withSandboxedChromeFlags (_seleniumSetupConfig_headless config) $ \chromeFlags -> do
78+ withSeleniumServer (_seleniumSetupConfig_seleniumPort config) $ do
79+ let browserPath = T.strip $ T.pack $ _seleniumSetupConfig_chromiumPath config
6580 when (T.null browserPath) $ fail "No browser found"
66− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
81+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }
6782 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
68− hspec (sessionWith wdConfig "" . using [(chromeCaps', "")] $ actualTests) `finally` _selenium_stopServer selenium
69−
70−seleniumPort, jsaddlePort :: PortNumber
71−seleniumPort = 8000
72−jsaddlePort = 8001
73−
74−data Selenium = Selenium
75− { _selenium_portNumber :: PortNumber
76− , _selenium_stopServer :: IO ()
77− }
83+ runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]
7884
7985startSeleniumServer :: PortNumber -> IO (IO ())
8086startSeleniumServer port = do
@@ -85,14 +91,10 @@ startSeleniumServer port = do
8591 }
8692 return $ terminateProcess ph
8793
88−withSeleniumServer :: (Selenium -> IO ()) -> IO ()
89−withSeleniumServer f = do
90− stopServer <- startSeleniumServer seleniumPort
94+withSeleniumServer :: PortNumber -> IO a -> IO a
95+withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do
9196 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
92− f $ Selenium
93− { _selenium_portNumber = seleniumPort
94− , _selenium_stopServer = stopServer
95− }
97+ f
9698
9799chromeConfig :: Text -> [Text] -> WD.WDConfig
98100chromeConfig fp flags =
@@ -104,20 +106,25 @@ chromeConfig fp flags =
104106-- Function to test widgets
105107--------------------------------------------------------------------------------
106108
109+-- | The environment in which your widgets can be tested
107110type TestWidget js t m =
108111 (DomBuilder t m, MonadHold t m, PostBuild t m
109112 , Prerender js t m, PerformEvent t m, TriggerEvent t m
110113 , MonadFix m, MonadIO (Performable m), MonadIO m)
111114
115+-- | Configuration of individual tests
112116data TestWidgetConfig = TestWidgetConfig
113− { testWidgetConfig_debug :: Bool
117+ { _testWidgetConfig_debug :: Bool
114118 -- ^ If this flag is set to True, during the test we will emit debug messages
115− -- giving insight on our progress in the hydratation progress
116− , testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
119+ , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
117120 -- ^ We can add widgets here that will be included in the head of the page
118121 -- (useful for example to include external js libraries in the tests)
122+ , _testWidgetConfig_jsaddlePort :: PortNumber
123+ -- ^ Port used by the jsaddle server
119124 }
120125
126+-- | Test a widget by running some webdriver commands before and after
127+-- hydration.
121128testWidget
122129 :: TestWidgetConfig
123130 -> WD a
@@ -129,15 +136,18 @@ testWidget
129136 -> WD b
130137testWidget cfg before after widget = testWidget' cfg before (const after) widget
131138
139+-- | Test a widget by running some webdriver commands before hydration (on the
140+-- statically rendered page).
132141testWidgetStatic
133142 :: TestWidgetConfig
134− -> WD ()
143+ -> WD a
135144 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
136145 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
137146 -- ^ Widget we are testing (contents of body)
138− -> WD ()
139−testWidgetStatic cfg before widget = testWidget' cfg (void before) (const $ pure ()) widget
147+ -> WD a
148+testWidgetStatic cfg before widget = testWidget' cfg before pure widget
140149
150+-- | Test a widget by running some webdriver commands after hydration.
141151testWidgetHydrated
142152 :: TestWidgetConfig
143153 -> WD b
@@ -147,6 +157,9 @@ testWidgetHydrated
147157 -> WD b
148158testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
149159
160+-- | Test a widget by running some webdriver commands before and after
161+-- hydration. Like 'testWidget', but you can use the result of the webdriver
162+-- commands from before hydration in the post hydration test.
150163testWidget'
151164 :: TestWidgetConfig
152165 -> WD a
@@ -156,7 +169,7 @@ testWidget'
156169 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
157170 -- ^ Widget we are testing (contents of body)
158171 -> WD b
159−testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover bodyWidget = do
172+testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do
160173 let putStrLnDebug :: MonadIO m => Text -> m ()
161174 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
162175 staticApp = do
@@ -196,8 +209,8 @@ testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover
196209 putStrLnDebug "put waitJSaddle"
197210 ]
198211 -- hSilence to get rid of ConnectionClosed logs
199− silenceIfDebug = if withDebugging then id else hSilence [stderr]
200− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
212+ silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]
213+ jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application
201214 withAsync' jsaddleWarp $ do
202215 putStrLnDebug "taking waitJSaddle"
203216 liftIO $ takeMVar waitJSaddle
@@ -216,39 +229,21 @@ testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover
216229-- Utilities
217230--------------------------------------------------------------------------------
218231
232+-- | Embed a different spec type by evaluating it directly.
233+embedSpec :: (Hspec.Example a, MonadIO m) => Hspec.Arg a -> a -> m ()
234+embedSpec arg spec = liftIO $ do
235+ Hspec.Result _info status <- Hspec.evaluateExample
236+ spec
237+ Hspec.defaultParams
238+ (\actionWith -> actionWith arg)
239+ (\_ -> pure ())
240+ case status of
241+ Hspec.Success -> pure ()
242+ Hspec.Pending _ _ -> pure () -- should not happen
243+ failure -> throwIO failure
244+
219245withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
220246withAsync' f g = bracket
221247 (liftIO $ Async.async f)
222248 (liftIO . Async.uninterruptibleCancel)
223249 (const g)
224−
225−--------------------------------------------------------------------------------
226−
227−{- Note: a nicer interface?
228−
229−This would have lead to a niced interface, but I don't think this solution is
230−expressible with the library
231−
232−data SessionData = SessionData
233− { sessionData_wdConfig :: WD.WDConfig
234− , sessionData_capabilities :: [Capabilities]
235− , sessionData_selenium :: Selenium
236− }
237−
238−testSpec = around bracketSelenium $ do
239− describe "createRecipe" $ _what
240−
241−bracketSelenium :: (SessionData -> IO ()) -> IO ()
242−bracketSelenium action = do
243− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
244− isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"
245− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
246− withSeleniumServer $ \selenium -> do
247− let browserPath = T.strip $ T.pack chromium
248− when (T.null browserPath) $ fail "No browser found"
249− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
250− let
251− wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
252− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
253− action (SessionData wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
254−-}