@@ -0,0 +1,292 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecursiveDo #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE ConstraintKinds #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13+{-# LANGUAGE LambdaCase #-}
14+
15+
16+module Reflex.Dom.Test.Screenshot where
17+
18+
19+import Control.Concurrent
20+import Control.Exception ()
21+import Control.Monad
22+import Control.Monad.Fix
23+import Control.Monad.IO.Class
24+import Data.Text (Text)
25+import qualified Data.Text as T
26+import Language.Javascript.JSaddle
27+import Language.Javascript.JSaddle.Warp
28+import Reflex.Dom.Core
29+import System.Exit
30+import System.Process
31+import Control.Monad.Catch
32+
33+import Test.Util.ChromeFlags
34+import Test.Util.UnshareNetwork
35+
36+import Test.WebDriver
37+import Test.WebDriver.Commands
38+import Control.Concurrent.Async
39+import qualified Control.Concurrent.Async as Async
40+import Network.Socket
41+import System.Environment
42+import System.Which (staticWhich)
43+import Data.Maybe
44+import qualified Data.Text.Encoding as TE
45+import qualified Data.ByteString.Lazy as LBS
46+import qualified Network.Wai.Handler.Warp as Warp
47+import Network.WebSockets
48+
49+import Network.Wai
50+import Network.HTTP.Types (status200)
51+import System.IO.Silently
52+import System.IO
53+
54+import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
55+import qualified Test.WebDriver as WD
56+import qualified Test.WebDriver.Capabilities as WD
57+
58+deriving instance MonadMask WD
59+
60+chromium :: FilePath
61+chromium = $(staticWhich "chromium")
62+
63+myWDConfig :: WDConfig
64+myWDConfig = useBrowser chrome $ defaultConfig { wdPort = 4444 }
65+-- myWDConfig = useBrowser chrome $ defaultConfig
66+
67+followingH :: IO ()
68+followingH = do
69+ handle (\(_ :: IOError) -> return ()) $ unshareNetork -- If we run into an exception with sandboxing, just don't bother
70+ isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
71+ withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
72+ withSeleniumServer $ \selenium -> do
73+ let browserPath = T.strip $ T.pack chromium
74+ when (T.null browserPath) $ fail "No browser found"
75+ withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
76+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
77+ 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
168+
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 ()
176+
177+data Selenium = Selenium
178+ { _selenium_portNumber :: PortNumber
179+ , _selenium_stopServer :: IO ()
180+ }
181+
182+startSeleniumServer :: PortNumber -> IO (IO ())
183+startSeleniumServer port = do
184+ (_,_,_,ph) <- createProcess $ (proc "selenium-server" ["-port", show port])
185+ { std_in = NoStream
186+ , std_out = NoStream
187+ , std_err = NoStream
188+ }
189+ return $ terminateProcess ph
190+
191+withSeleniumServer :: (Selenium -> IO ()) -> IO ()
192+withSeleniumServer f = do
193+ stopServer <- startSeleniumServer seleniumPort
194+ threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
195+ f $ Selenium
196+ { _selenium_portNumber = seleniumPort
197+ , _selenium_stopServer = stopServer
198+ }
199+
200+chromeConfig :: Text -> [Text] -> WD.WDConfig
201+chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
202+
203+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)
204+
205+-- | TODO: do something about JSExceptions not causing tests to fail
206+testWidgetDebug
207+ :: Bool
208+ -> WD ()
209+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
210+ -> WD b
211+ -- ^ Webdriver commands to run after hydration switchover
212+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
213+ -- ^ Widget we are testing
214+ -> WD b
215+testWidgetDebug withDebugging beforeJS afterSwitchover =
216+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
217+
218+-- | TODO: do something about JSExceptions not causing tests to fail
219+testWidgetDebug'
220+ :: Bool
221+ -> WD a
222+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
223+ -> (a -> WD b)
224+ -- ^ Webdriver commands to run after hydration switchover
225+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
226+ -- ^ Widget we are testing (contents of body)
227+ -> WD b
228+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
229+ let putStrLnDebug :: MonadIO m => Text -> m ()
230+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
231+ staticApp = do
232+ el "head" $ pure ()
233+ el "body" $ do
234+ bodyWidget
235+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
236+ putStrLnDebug "rendering static"
237+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
238+ putStrLnDebug "rendered static"
239+ waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
240+ waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
241+ let entryPoint = do
242+ putStrLnDebug "taking waitBeforeJS"
243+ liftIO $ takeMVar waitBeforeJS
244+ let switchOverAction = do
245+ putStrLnDebug "switchover syncPoint"
246+ syncPoint
247+ putStrLnDebug "putting waitUntilSwitchover"
248+ liftIO $ putMVar waitUntilSwitchover ()
249+ putStrLnDebug "put waitUntilSwitchover"
250+ putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
251+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
252+ putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
253+ syncPoint
254+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
255+ putStrLnDebug "sending response"
256+ r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
257+ putStrLnDebug "sent response"
258+ return r
259+ waitJSaddle <- liftIO newEmptyMVar
260+ let settings = foldr ($) Warp.defaultSettings
261+ [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
262+ , Warp.setBeforeMainLoop $ do
263+ putStrLnDebug "putting waitJSaddle"
264+ putMVar waitJSaddle ()
265+ putStrLnDebug "put waitJSaddle"
266+ ]
267+ -- hSilence to get rid of ConnectionClosed logs
268+ silenceIfDebug = if withDebugging then id else hSilence [stderr]
269+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
270+ withAsync' jsaddleWarp $ do
271+ putStrLnDebug "taking waitJSaddle"
272+ liftIO $ takeMVar waitJSaddle
273+ putStrLnDebug "opening page"
274+ WD.openPage $ "http://localhost:" <> show jsaddlePort
275+ putStrLnDebug "running beforeJS"
276+ a <- beforeJS
277+ putStrLnDebug "putting waitBeforeJS"
278+ liftIO $ putMVar waitBeforeJS ()
279+ putStrLnDebug "taking waitUntilSwitchover"
280+ liftIO $ takeMVar waitUntilSwitchover
281+ putStrLnDebug "running afterSwitchover"
282+ afterSwitchover a
283+
284+seleniumPort, jsaddlePort :: PortNumber
285+seleniumPort = 8000
286+jsaddlePort = 8001
287+
288+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
289+withAsync' f g = bracket
290+ (liftIO $ Async.async f)
291+ (liftIO . Async.uninterruptibleCancel)
292+ (const g)