@@ -1,119 +1,74 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
34{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RecursiveDo #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
65{-# LANGUAGE RankNTypes #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TemplateHaskell #-}
10−{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
117{-# LANGUAGE StandaloneDeriving #-}
12−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13−{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE TemplateHaskell #-}
149
10+{-# OPTIONS_GHC -fno-warn-orphans #-}
1511
1612module Reflex.Dom.Test.Screenshot
17− (testWithSelenium, testWidgetDebug'WithHead)
18−
19− where
20−
13+ ( TestWidget
14+ , TestWidgetConfig (..)
15+ , testWidget, testWidget', testWidgetStatic, testWidgetHydrated
16+ , testWithSelenium
17+ ) where
2118
22−import Control.Concurrent
23−import Control.Exception ()
24−import Control.Monad
25−import Control.Monad.Fix
26−import Control.Monad.IO.Class
19+import Control.Concurrent (threadDelay, newEmptyMVar, takeMVar, putMVar)
20+import Control.Monad (when, void)
21+import Control.Monad.Catch (MonadMask, handle, finally)
22+import Control.Monad.Fix (MonadFix)
23+import Control.Monad.IO.Class (MonadIO, liftIO)
2724import Data.Text (Text)
28−import qualified Data.Text as T
2925import Language.Javascript.JSaddle
3026import Language.Javascript.JSaddle.Warp
27+import Network.HTTP.Types (status200)
28+import Network.Socket (PortNumber)
29+import Network.Wai (responseLBS)
30+import Network.WebSockets (defaultConnectionOptions)
3131import Reflex.Dom.Core
32−-- import System.Exit
33−import System.Process
34−import Control.Monad.Catch
35−
36−import Test.Util.ChromeFlags
37−import Test.Util.UnshareNetwork
32+import System.IO (stderr)
33+import System.IO.Silently (hSilence)
34+import System.Process (std_in, std_out, std_err, createProcess, proc, StdStream (..), terminateProcess)
35+import System.Which (staticWhich)
36+import qualified Data.Text as T
3837
39−import Test.WebDriver
40−-- import Test.WebDriver.Commands
41−-- import Control.Concurrent.Async
4238import qualified Control.Concurrent.Async as Async
43−import Network.Socket
44−import System.Environment
45−import System.Which (staticWhich)
46−import Data.Maybe
4739import qualified Data.Text.Encoding as TE
4840import qualified Data.ByteString.Lazy as LBS
4941import qualified Network.Wai.Handler.Warp as Warp
50−import Network.WebSockets
5142
52−import Network.Wai
53−import Network.HTTP.Types (status200)
54−import System.IO.Silently
55−import System.IO
56−
57−import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
43+import Test.Hspec.WebDriver (SpecWith, WdTestSession, hspec, sessionWith, using)
44+import Test.Util.ChromeFlags
45+import Test.Util.UnshareNetwork
46+import Test.WebDriver (WD)
5847import qualified Test.WebDriver as WD
5948import qualified Test.WebDriver.Capabilities as WD
6049
6150deriving instance MonadMask WD
6251
63−chromium :: FilePath
64−chromium = $(staticWhich "chromium")
65−
66−myWDConfig :: WDConfig
67−myWDConfig = useBrowser chrome $ defaultConfig { wdPort = 4444 }
68−
69−data SessionData = SessionData
70− { sessionData_wdConfig :: WD.WDConfig
71− , sessionData_capabilities :: [Capabilities]
72− , sessionData_selenium :: Selenium
73− }
74−
75−{- Note: a nicer interface?
76−
77−This would have lead to a niced interface, but I don't think this solution is
78−expressible with the library
79−
80−testSpec = around bracketSelenium $ do
81− describe "createRecipe" $ _what
82−
83−bracketSelenium :: (SessionData -> IO ()) -> IO ()
84−bracketSelenium action = do
85− handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
86− isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"
87− withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
88− withSeleniumServer $ \selenium -> do
89− let browserPath = T.strip $ T.pack chromium
90− when (T.null browserPath) $ fail "No browser found"
91− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
92− let
93− wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
94− chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
95− action (SessionData wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
96−-}
97−
98−testWithSelenium :: SpecWith (WdTestSession a) -> IO ()
99−testWithSelenium actualTests = do
52+testWithSelenium
53+ :: Bool
54+ -- ^ True means that the browser is invoked in headless mode, False means that
55+ -- the user can see the interaction happening on the browser (useful for debugging).
56+ -> SpecWith (WdTestSession a)
57+ -- ^ The tests we want to write in the selenium session
58+ -> IO ()
59+testWithSelenium isHeadless actualTests = do
10060 handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
101− isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"
10261 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
10362 withSeleniumServer $ \selenium -> do
10463 let browserPath = T.strip $ T.pack chromium
10564 when (T.null browserPath) $ fail "No browser found"
106− withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
10765 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
10866 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
10967 hspec (sessionWith wdConfig "" . using [(chromeCaps', "")] $ actualTests) `finally` _selenium_stopServer selenium
11068
111−-- testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
112−-- testWidgetStatic = testWidgetStaticDebug withDebugging
113−-- testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
114−-- testWidget = testWidgetDebug withDebugging
115−-- testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
116−-- testWidget' = testWidgetDebug' withDebugging
69+seleniumPort, jsaddlePort :: PortNumber
70+seleniumPort = 8000
71+jsaddlePort = 8001
11772
11873data Selenium = Selenium
11974 { _selenium_portNumber :: PortNumber
@@ -138,95 +93,64 @@ withSeleniumServer f = do
13893 , _selenium_stopServer = stopServer
13994 }
14095
96+chromium :: FilePath
97+chromium = $(staticWhich "chromium")
98+
14199chromeConfig :: Text -> [Text] -> WD.WDConfig
142−chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
100+chromeConfig fp flags =
101+ WD.useBrowser
102+ (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags })
103+ WD.defaultConfig
143104
144−type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
105+--------------------------------------------------------------------------------
106+-- Function to test widgets
107+--------------------------------------------------------------------------------
145108
146−-- | TODO: do something about JSExceptions not causing tests to fail
147−testWidgetDebug
148− :: Bool
149− -> WD ()
109+type TestWidget js t m =
110+ (DomBuilder t m, MonadHold t m, PostBuild t m
111+ , Prerender js t m, PerformEvent t m, TriggerEvent t m
112+ , MonadFix m, MonadIO (Performable m), MonadIO m)
113+
114+data TestWidgetConfig = TestWidgetConfig
115+ { testWidgetConfig_debug :: Bool
116+ -- ^ If this flag is set to True, during the test we will emit debug messages
117+ -- giving insight on our progress in the hydratation progress
118+ , testWidgetConfig_headWidget :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
119+ -- ^ We can add widgets here that will be included in the head of the page
120+ -- (useful for example to include external js libraries in the tests)
121+ }
122+
123+testWidget
124+ :: TestWidgetConfig
125+ -> WD a
150126 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
151127 -> WD b
152128 -- ^ Webdriver commands to run after hydration switchover
153129 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
154− -- ^ Widget we are testing
130+ -- ^ Widget we are testing (contents of body)
155131 -> WD b
156−testWidgetDebug withDebugging beforeJS afterSwitchover =
157− testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
132+testWidget cfg before after widget = testWidget' cfg before (const after) widget
158133
159−testWidgetDebug'WithHead
160− :: Bool
161− -> WD a
134+testWidgetStatic
135+ :: TestWidgetConfig
136+ -> WD ()
162137 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
163− -> (a -> WD b)
164− -- ^ Webdriver commands to run after hydration switchover
165138 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
166− -- ^ Widget that we want to put in the head additionally
139+ -- ^ Widget we are testing (contents of body)
140+ -> WD ()
141+testWidgetStatic cfg before widget = testWidget' cfg (void before) (const $ pure ()) widget
142+
143+testWidgetHydrated
144+ :: TestWidgetConfig
145+ -> WD b
146+ -- ^ Webdriver commands to run after hydration switchover
167147 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
168148 -- ^ Widget we are testing (contents of body)
169149 -> WD b
170−testWidgetDebug'WithHead withDebugging beforeJS afterSwitchover headWidget bodyWidget = do
171− let putStrLnDebug :: MonadIO m => Text -> m ()
172− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
173− staticApp = do
174− el "head" $ headWidget
175− el "body" $ do
176− bodyWidget
177− el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
178− putStrLnDebug "rendering static"
179− ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
180− putStrLnDebug "rendered static"
181− waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
182− waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
183− let entryPoint = do
184− putStrLnDebug "taking waitBeforeJS"
185− liftIO $ takeMVar waitBeforeJS
186− let switchOverAction = do
187− putStrLnDebug "switchover syncPoint"
188− syncPoint
189− putStrLnDebug "putting waitUntilSwitchover"
190− liftIO $ putMVar waitUntilSwitchover ()
191− putStrLnDebug "put waitUntilSwitchover"
192− putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
193− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
194− putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
195− syncPoint
196− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \req sendResponse -> do
197− putStrLnDebug "sending response"
198− putStrLnDebug $ "The request was: " <> T.pack (show req)
199− r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
200− putStrLnDebug "sent response"
201− return r
202− waitJSaddle <- liftIO newEmptyMVar
203− let settings = foldr ($) Warp.defaultSettings
204− [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
205− , Warp.setBeforeMainLoop $ do
206− putStrLnDebug "putting waitJSaddle"
207− putMVar waitJSaddle ()
208− putStrLnDebug "put waitJSaddle"
209− ]
210− -- hSilence to get rid of ConnectionClosed logs
211− silenceIfDebug = if withDebugging then id else hSilence [stderr]
212− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
213− withAsync' jsaddleWarp $ do
214− putStrLnDebug "taking waitJSaddle"
215− liftIO $ takeMVar waitJSaddle
216− putStrLnDebug "opening page"
217− WD.openPage $ "http://localhost:" <> show jsaddlePort
218− putStrLnDebug "running beforeJS"
219− a <- beforeJS
220− putStrLnDebug "putting waitBeforeJS"
221− liftIO $ putMVar waitBeforeJS ()
222− putStrLnDebug "taking waitUntilSwitchover"
223− liftIO $ takeMVar waitUntilSwitchover
224− putStrLnDebug "running afterSwitchover"
225− afterSwitchover a
150+testWidgetHydrated cfg after widget = testWidget' cfg (pure ()) (const after) widget
226151
227−-- | TODO: do something about JSExceptions not causing tests to fail
228−testWidgetDebug'
229− :: Bool
152+testWidget'
153+ :: TestWidgetConfig
230154 -> WD a
231155 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
232156 -> (a -> WD b)
@@ -234,11 +158,11 @@ testWidgetDebug'
234158 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
235159 -- ^ Widget we are testing (contents of body)
236160 -> WD b
237−testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
161+testWidget' (TestWidgetConfig withDebugging headWidget) beforeJS afterSwitchover bodyWidget = do
238162 let putStrLnDebug :: MonadIO m => Text -> m ()
239163 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
240164 staticApp = do
241− el "head" $ pure ()
165+ el "head" $ headWidget
242166 el "body" $ do
243167 bodyWidget
244168 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
@@ -290,9 +214,9 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
290214 putStrLnDebug "running afterSwitchover"
291215 afterSwitchover a
292216
293−seleniumPort, jsaddlePort :: PortNumber
294−seleniumPort = 8000
295−jsaddlePort = 8001
217+--------------------------------------------------------------------------------
218+-- Utilities
219+--------------------------------------------------------------------------------
296220
297221withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
298222withAsync' f g = bracket
@@ -300,15 +224,33 @@ withAsync' f g = bracket
300224 (liftIO . Async.uninterruptibleCancel)
301225 (const g)
302226
303−testWidgetStaticDebug
304− :: Bool
305− -> WD b
306− -- ^ Webdriver commands to run before JS runs and after hydration switchover
307− -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
308− -- ^ Widget we are testing
309− -> WD b
310−testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
311−
312−--------------------------------------------------------------------------------
313−-- Tasty
314227--------------------------------------------------------------------------------
228+
229+{- Note: a nicer interface?
230+
231+This would have lead to a niced interface, but I don't think this solution is
232+expressible with the library
233+
234+data SessionData = SessionData
235+ { sessionData_wdConfig :: WD.WDConfig
236+ , sessionData_capabilities :: [Capabilities]
237+ , sessionData_selenium :: Selenium
238+ }
239+
240+testSpec = around bracketSelenium $ do
241+ describe "createRecipe" $ _what
242+
243+bracketSelenium :: (SessionData -> IO ()) -> IO ()
244+bracketSelenium action = do
245+ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
246+ isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"
247+ withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
248+ withSeleniumServer $ \selenium -> do
249+ let browserPath = T.strip $ T.pack chromium
250+ when (T.null browserPath) $ fail "No browser found"
251+ withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
252+ let
253+ wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
254+ chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
255+ action (SessionData wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
256+-}