@@ -0,0 +1,249 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+
10+{-# OPTIONS_GHC -fno-warn-orphans #-}
11+
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
18+ ( TestWidget
19+ , TestWidgetConfig (..)
20+ , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
21+ , withSeleniumSpec
22+ , embedSpec
23+ , SeleniumSetupConfig (..)
24+ ) where
25+
26+import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
27+import Control.Exception (throwIO)
28+import Control.Monad (when)
29+import Control.Monad.Catch (MonadMask, handle)
30+import Control.Monad.Fix (MonadFix)
31+import Control.Monad.IO.Class (MonadIO, liftIO)
32+import Data.Text (Text)
33+import Language.Javascript.JSaddle
34+import Language.Javascript.JSaddle.Warp
35+import Network.HTTP.Types (status200)
36+import Network.Socket (PortNumber)
37+import Network.Wai (responseLBS)
38+import Network.WebSockets (defaultConnectionOptions)
39+import Reflex.Dom.Core
40+import System.IO (stderr)
41+import System.IO.Silently (hSilence)
42+import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
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)
47+
48+import qualified Control.Concurrent.Async as Async
49+import qualified Data.ByteString.Lazy as LBS
50+import qualified Data.Text as T
51+import qualified Data.Text.Encoding as TE
52+import qualified Network.Wai.Handler.Warp as Warp
53+import qualified Test.Hspec.Core.Spec as Hspec
54+import qualified Test.WebDriver as WD
55+import qualified Test.WebDriver.Capabilities as WD
56+
57+deriving instance MonadMask WD
58+
59+data SeleniumSetupConfig = SeleniumSetupConfig
60+ { _seleniumSetupConfig_chromiumPath :: FilePath
61+ -- ^ Path to the chromium executable
62+ , _seleniumSetupConfig_headless :: Bool
63+ -- ^ True means that the browser is invoked in headless mode, False means that
64+ -- the user can see the interaction happening on the browser (useful for debugging).
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
80+ when (T.null browserPath) $ fail "No browser found"
81+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _seleniumSetupConfig_seleniumPort config }
82+ chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
83+ runSpec $ sessionWith wdConfig "" . using [(chromeCaps', "chrome")]
84+
85+startSeleniumServer :: PortNumber -> IO (IO ())
86+startSeleniumServer port = do
87+ (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
88+ { std_in = NoStream
89+ , std_out = NoStream
90+ , std_err = NoStream
91+ }
92+ return $ terminateProcess ph
93+
94+withSeleniumServer :: PortNumber -> IO a -> IO a
95+withSeleniumServer port f = bracket (startSeleniumServer port) id $ \_ -> do
96+ threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
97+ f
98+
99+chromeConfig :: Text -> [Text] -> WD.WDConfig
100+chromeConfig fp flags =
101+ WD.useBrowser
102+ (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags })
103+ WD.defaultConfig
104+
105+--------------------------------------------------------------------------------
106+-- Function to test widgets
107+--------------------------------------------------------------------------------
108+
109+-- | The environment in which your widgets can be tested
110+type TestWidget js t m =
111+ (DomBuilder t m, MonadHold t m, PostBuild t m
112+ , Prerender js t m, PerformEvent t m, TriggerEvent t m
113+ , MonadFix m, MonadIO (Performable m), MonadIO m)
114+
115+-- | Configuration of individual tests
116+data TestWidgetConfig = TestWidgetConfig
117+ { _testWidgetConfig_debug :: Bool
118+ -- ^ If this flag is set to True, during the test we will emit debug messages
119+ , _testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
120+ -- ^ We can add widgets here that will be included in the head of the page
121+ -- (useful for example to include external js libraries in the tests)
122+ , _testWidgetConfig_jsaddlePort :: PortNumber
123+ -- ^ Port used by the jsaddle server
124+ }
125+
126+-- | Test a widget by running some webdriver commands before and after
127+-- hydration.
128+testWidget
129+ :: TestWidgetConfig
130+ -> WD a
131+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
132+ -> WD b
133+ -- ^ Webdriver commands to run after hydration switchover
134+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
135+ -- ^ Widget we are testing (contents of body)
136+ -> WD b
137+testWidget cfg before after widget = testWidget' cfg before (const after) widget
138+
139+-- | Test a widget by running some webdriver commands before hydration (on the
140+-- statically rendered page).
141+testWidgetStatic
142+ :: TestWidgetConfig
143+ -> WD a
144+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
145+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
146+ -- ^ Widget we are testing (contents of body)
147+ -> WD a
148+testWidgetStatic cfg before widget = testWidget' cfg before pure widget
149+
150+-- | Test a widget by running some webdriver commands after hydration.
151+testWidgetHydrated
152+ :: TestWidgetConfig
153+ -> WD b
154+ -- ^ Webdriver commands to run after hydration switchover
155+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
156+ -- ^ Widget we are testing (contents of body)
157+ -> WD b
158+testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
159+
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.
163+testWidget'
164+ :: TestWidgetConfig
165+ -> WD a
166+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
167+ -> (a -> WD b)
168+ -- ^ Webdriver commands to run after hydration switchover
169+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
170+ -- ^ Widget we are testing (contents of body)
171+ -> WD b
172+testWidget' (TestWidgetConfig withDebugging headWidget jsaddlePort) beforeJS afterSwitchover bodyWidget = do
173+ let putStrLnDebug :: MonadIO m => Text -> m ()
174+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
175+ staticApp = do
176+ el "head" $ headWidget
177+ el "body" $ do
178+ bodyWidget
179+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
180+ putStrLnDebug "rendering static"
181+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
182+ putStrLnDebug "rendered static"
183+ waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
184+ waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
185+ let entryPoint = do
186+ putStrLnDebug "taking waitBeforeJS"
187+ liftIO $ takeMVar waitBeforeJS
188+ let switchOverAction = do
189+ putStrLnDebug "switchover syncPoint"
190+ syncPoint
191+ putStrLnDebug "putting waitUntilSwitchover"
192+ liftIO $ putMVar waitUntilSwitchover ()
193+ putStrLnDebug "put waitUntilSwitchover"
194+ putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
195+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
196+ putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
197+ syncPoint
198+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
199+ putStrLnDebug "sending response"
200+ r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
201+ putStrLnDebug "sent response"
202+ return r
203+ waitJSaddle <- liftIO newEmptyMVar
204+ let settings = foldr ($) Warp.defaultSettings
205+ [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
206+ , Warp.setBeforeMainLoop $ do
207+ putStrLnDebug "putting waitJSaddle"
208+ putMVar waitJSaddle ()
209+ putStrLnDebug "put waitJSaddle"
210+ ]
211+ -- hSilence to get rid of ConnectionClosed logs
212+ silenceIfNotDebugging = if withDebugging then id else hSilence [stderr]
213+ jsaddleWarp = silenceIfNotDebugging $ Warp.runSettings settings application
214+ withAsync' jsaddleWarp $ do
215+ putStrLnDebug "taking waitJSaddle"
216+ liftIO $ takeMVar waitJSaddle
217+ putStrLnDebug "opening page"
218+ WD.openPage $ "http://localhost:" <> show jsaddlePort
219+ putStrLnDebug "running beforeJS"
220+ a <- beforeJS
221+ putStrLnDebug "putting waitBeforeJS"
222+ liftIO $ putMVar waitBeforeJS ()
223+ putStrLnDebug "taking waitUntilSwitchover"
224+ liftIO $ takeMVar waitUntilSwitchover
225+ putStrLnDebug "running afterSwitchover"
226+ afterSwitchover a
227+
228+--------------------------------------------------------------------------------
229+-- Utilities
230+--------------------------------------------------------------------------------
231+
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+
245+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
246+withAsync' f g = bracket
247+ (liftIO $ Async.async f)
248+ (liftIO . Async.uninterruptibleCancel)
249+ (const g)