@@ -13,7 +13,10 @@
1313{-# LANGUAGE LambdaCase #-}
1414
1515
16−module Reflex.Dom.Test.Screenshot where
16+module Reflex.Dom.Test.Screenshot
17+ (testWithSelenium, testWidgetDebug'WithHead)
18+
19+ where
1720
1821
1922import Control.Concurrent
@@ -26,7 +29,7 @@ import qualified Data.Text as T
2629import Language.Javascript.JSaddle
2730import Language.Javascript.JSaddle.Warp
2831import Reflex.Dom.Core
29−import System.Exit
32+-- import System.Exit
3033import System.Process
3134import Control.Monad.Catch
3235
@@ -34,8 +37,8 @@ import Test.Util.ChromeFlags
3437import Test.Util.UnshareNetwork
3538
3639import Test.WebDriver
37−import Test.WebDriver.Commands
38−import Control.Concurrent.Async
40+-- import Test.WebDriver.Commands
41+-- import Control.Concurrent.Async
3942import qualified Control.Concurrent.Async as Async
4043import Network.Socket
4144import System.Environment
@@ -62,12 +65,40 @@ chromium = $(staticWhich "chromium")
6265
6366myWDConfig :: WDConfig
6467myWDConfig = useBrowser chrome $ defaultConfig { wdPort = 4444 }
65−-- myWDConfig = useBrowser chrome $ defaultConfig
6668
67−followingH :: IO ()
68−followingH = do
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
69100 handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
70− isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
101+ isHeadless <- pure True -- (== Nothing) <$> lookupEnv "NO_HEADLESS"
71102 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
72103 withSeleniumServer $ \selenium -> do
73104 let browserPath = T.strip $ T.pack chromium
@@ -75,104 +106,14 @@ followingH = do
75106 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
76107 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
77108 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
78− -- TODO I don't want this to call hspec
79− tests withDebugging wdConfig [chromeCaps'] selenium `finally` _selenium_stopServer selenium
80−
81−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> IO ()
82−tests withDebugging wdConfig caps _selenium = do
83− let putStrLnDebug :: MonadIO m => Text -> m ()
84− putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
85− -- session' :: SpecWith (WdTestSession multi) -> Spec
86− -- session' = sessionWith wdConfig "" . (using :: Int) (map (,"") caps)
87− -- runWD :: WD () -> WdExample ()
88− -- runWD m = runWDOptions (WdOptions False) $ do
89− -- putStrLnDebug "before"
90− -- r <- m
91− -- putStrLnDebug "after"
92− -- return r
93− testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
94− -- testWidget :: WD () -> WD b -> (forall m. Widget (SpiderTimeline Global) m) -> WD b
95− testWidget = testWidgetDebug withDebugging
96− -- session' $ do
97− putStrLn "inside tests"
98− runSession (useBrowser chrome $ wdConfig) $
99− testWidget (checkBodyText "hello world") (saveScreenshot "/home/carlo/tmp/primo.png") $ do
100− elAttr "div" ("style" =: "background-color: cyan;") $ text "hello world"
101− putStrLn "Done"
102−
103−checkBodyText :: Text -> WD ()
104−checkBodyText = checkTextInTag "body"
105−
106−checkTextInTag :: Text -> Text -> WD ()
107−checkTextInTag t expected = do
108− e <- findElemWithRetry (WD.ByTag t)
109− shouldContainText expected e
110−
111−findElemWithRetry :: Selector -> WD WD.Element
112−findElemWithRetry = withRetry . WD.findElem
113−
114−shouldContainText :: Text -> WD.Element -> WD ()
115−shouldContainText t = withRetry . shouldContainTextNoRetry t
116−
117−withRetry :: forall a. WD a -> WD a
118−withRetry a = wait 300
119− where wait :: Int -> WD a
120− wait 0 = a
121− wait n = try a >>= \case
122− Left (e :: SomeException) -> do
123− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
124− wait $ n - 1
125− Right v -> return v
126−
127−shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
128−shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
129−
130−-- createScreenshot :: forall t m. (DomBuilder t m, MonadHold t m, MonadFix m) => m () -> IO ()
131−-- createScreenshot :: (forall t. Widget t a) -> IO ()
132−-- createScreenshot widget = do
133−-- handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
134−-- withSandboxedChromeFlags True $ \chromeFlags -> do
135−-- mainThread <- myThreadId
136−-- browserProcess <- spawnCommand $ mconcat
137−-- [ "echo 'Starting Chromium' ; chromium "
138−-- , T.unpack $ T.unwords chromeFlags
139−-- , " http://localhost:3911 ; echo 'Chromium exited'"
140−-- ]
141−-- let
142−-- finishTest :: ExitCode -> IO ()
143−-- finishTest result = do
144−-- interruptProcessGroupOf browserProcess
145−-- throwTo mainThread result
146−-- putStrLn "About to start the server"
147−
148−-- liftIO $ putStrLn "Starting in the async.."
149−-- runSession myWDConfig $ do
150−-- -- tells the browser to open the URL http://google.com
151−-- liftIO $ putStrLn "Before opening the page.."
152−-- openPage "http://google.com"
153−-- liftIO $ putStrLn "Page opened"
154−-- saveScreenshot "/home/carlo/tmp/primo.png"
155−-- closeSession
156−-- -- async $ do
157−-- -- -- starts a WebDriver session with the given firefox config, then runs the
158−-- -- -- supplied commands
159−
160−-- -- liftIO $ putStrLn "Starting in the async.."
161−-- -- runSession myWDConfig $ do
162−-- -- -- tells the browser to open the URL http://google.com
163−-- -- liftIO $ putStrLn "Before opening the page.."
164−-- -- openPage "http://google.com"
165−-- -- liftIO $ putStrLn "Page opened"
166−-- -- saveScreenshot "/home/carlo/tmp/primo.png"
167−-- -- closeSession
109+ hspec (sessionWith wdConfig "" . using [(chromeCaps', "")] $ actualTests) `finally` _selenium_stopServer selenium
168110
169−-- run 3911 $ do
170−-- liftIO $ putStrLn "Running..."
171−-- mainWidget $ do
172−-- postBuild <- getPostBuild
173−-- performEvent_ <=< delay 10 $ (liftIO $ finishTest ExitSuccess) <$ postBuild
174−-- void widget
175−-- -- pure ()
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
176117
177118data Selenium = Selenium
178119 { _selenium_portNumber :: PortNumber
@@ -215,6 +156,74 @@ testWidgetDebug
215156testWidgetDebug withDebugging beforeJS afterSwitchover =
216157 testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
217158
159+testWidgetDebug'WithHead
160+ :: Bool
161+ -> WD a
162+ -- ^ 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
165+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
166+ -- ^ Widget that we want to put in the head additionally
167+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
168+ -- ^ Widget we are testing (contents of body)
169+ -> 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
226+
218227-- | TODO: do something about JSExceptions not causing tests to fail
219228testWidgetDebug'
220229 :: Bool
@@ -290,3 +299,16 @@ withAsync' f g = bracket
290299 (liftIO $ Async.async f)
291300 (liftIO . Async.uninterruptibleCancel)
292301 (const g)
302+
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
314+--------------------------------------------------------------------------------