@@ -0,0 +1,393 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+
12+import Control.Concurrent
13+import Control.Monad
14+import Control.Monad.Catch
15+import Control.Monad.Fix
16+import Control.Monad.IO.Class
17+import Data.Foldable (traverse_)
18+import Data.IORef
19+import Data.Maybe (fromMaybe)
20+import Data.Proxy
21+import Data.Text (Text)
22+import Language.Javascript.JSaddle (JSException(..), syncPoint)
23+import Language.Javascript.JSaddle.Warp
24+import Network.HTTP.Types (status200)
25+import Network.Wai
26+import Network.WebSockets
27+import Reflex.Dom.Core
28+import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
29+import System.Random
30+import System.Timeout
31+import Test.Hspec
32+import Test.HUnit
33+import Test.WebDriver (WD)
34+
35+--import System.IO.Silently
36+import System.IO.Temp
37+import System.IO
38+import GHC.IO.Handle (hDuplicate, hDuplicateTo)
39+
40+import qualified Data.ByteString.Lazy as LBS
41+import qualified Data.Text as T
42+import qualified Data.Text.Encoding as TE
43+import qualified Network.Wai.Handler.Warp as Warp
44+import qualified Test.WebDriver as WD
45+
46+testTimeLimit :: Int
47+testTimeLimit = 1 * 1000 * 1000
48+
49+chromeConfig :: WD.WDConfig
50+chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig
51+
52+-- TODO list
53+-- use only available ports
54+-- parallel (requires port fix)
55+
56+main :: IO ()
57+main = hspec $ parallel $ do
58+
59+ describe "text" $ parallel $ do
60+ it "works" $ do
61+ testWidgetStatic (checkBodyText "hello world") $ do
62+ text "hello world"
63+ it "works with postBuild" $ do
64+ testWidgetStatic (checkBodyText "pb") $ do
65+ pb <- getPostBuild
66+ void $ textNode $ TextNodeConfig "" $ Just $ "pb" <$ pb
67+ it "works for adjacent text nodes" $ do
68+ testWidgetStatic (checkBodyText "hello world") $ do
69+ text "hello "
70+ text "world"
71+ it "works for empty adjacent text nodes" $ do
72+ testWidgetStatic (checkBodyText "hello world") $ do
73+ pb <- getPostBuild
74+ text ""
75+ text ""
76+ _ <- textNode $ TextNodeConfig "" $ Just $ "hello " <$ pb
77+ _ <- textNode $ TextNodeConfig "abc" $ Just $ "" <$ pb
78+ _ <- textNode $ TextNodeConfig "" $ Just $ "world" <$ pb
79+ text ""
80+ it "works when empty text nodes are the only children of an element" $ do
81+ testWidgetStatic (checkBodyText "hello world") $ do
82+ el "div" $ do
83+ text ""
84+ text ""
85+ text "hello world"
86+ it "works when an empty text node is the first child before text" $ do
87+ testWidgetStatic (checkTextInTag "div" "hello world") $ do
88+ el "div" $ do
89+ text ""
90+ text "hello world"
91+ it "works when an empty text node is the first child before element" $ do
92+ testWidgetStatic (checkTextInTag "div" "hello world") $ do
93+ el "div" $ do
94+ text ""
95+ el "span" $ text "hello world"
96+ it "works when an empty text node is the last child" $ do
97+ testWidgetStatic (checkTextInTag "div" "hello world") $ do
98+ el "div" $ do
99+ el "span" $ text "hello world"
100+ text ""
101+
102+ it "updates after postBuild" $ do
103+ testWidget (checkBodyText "initial") (checkBodyText "after") $ do
104+ after <- delay 0 =<< getPostBuild
105+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ after
106+ it "updates immediately after postBuild" $ do
107+ testWidget (checkBodyText "pb") (checkBodyText "after") $ do
108+ pb <- getPostBuild
109+ after <- delay 0 pb
110+ void $ textNode $ TextNodeConfig "initial" $ Just $ leftmost ["pb" <$ pb, "after" <$ after]
111+ it "updates in immediate mode" $ do
112+ let checkUpdated = do
113+ checkBodyText "initial"
114+ WD.click =<< WD.findElem (WD.ByTag "button")
115+ liftIO $ threadDelay 100000 -- wait for update
116+ checkBodyText "after"
117+ testWidget (pure ()) checkUpdated $ prerender (pure ()) $ do
118+ click <- button ""
119+ void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
120+
121+ it "works when given differing results of prerender" $ do
122+ testWidgetStatic (pure ()) $ do
123+ text =<< prerender (pure "One") (pure "Two")
124+
125+
126+ describe "element" $ parallel $ do
127+ it "works with domEvent Click" $ do
128+ clickedRef <- newIORef False
129+ testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
130+ (e, _) <- el' "div" $ text "hello world"
131+ performEvent_ $ liftIO (writeIORef clickedRef True) <$ domEvent Click e
132+ clicked <- readIORef clickedRef
133+ assertEqual "Not clicked" True clicked
134+ it "works with eventFlags stopPropagation" $ do
135+ firstClickedRef <- newIORef False
136+ secondClickedRef <- newIORef False
137+ let clickBoth = do
138+ WD.findElem (WD.ById "first") >>= WD.click
139+ WD.findElem (WD.ById "second") >>= WD.click
140+ testWidget (pure ()) clickBoth $ do
141+ (firstDivEl, _) <- el' "div" $ prerender (pure ()) $ do
142+ void $ elAttr "span" ("id" =: "first") $ text "hello world"
143+ performEvent_ $ liftIO (writeIORef firstClickedRef True) <$ domEvent Click firstDivEl
144+ (secondDivEl, _) <- el' "div" $ prerender (pure ()) $ do
145+ let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace
146+ conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)
147+ & initialAttributes .~ "id" =: "second"
148+ & elementConfig_eventSpec .~ (addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> stopPropagation) def)
149+ void $ element "span" conf $ text "hello world"
150+ performEvent_ $ liftIO (writeIORef secondClickedRef True) <$ domEvent Click secondDivEl
151+ firstClicked <- readIORef firstClickedRef
152+ secondClicked <- readIORef secondClickedRef
153+ assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
154+ it "works with eventFlags preventDefault" $ do
155+ let click = do
156+ e <- WD.findElem $ WD.ByTag "input"
157+ s0 <- WD.isSelected e
158+ WD.click e
159+ s1 <- WD.isSelected e
160+ pure (s0, s1)
161+ clicked <- testWidget (pure ()) click $ prerender (pure ()) $ do
162+ let conf :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace
163+ conf = (def :: ElementConfig EventResult (SpiderTimeline Global) GhcjsDomSpace)
164+ & elementConfig_eventSpec .~ (addEventSpecFlags (Proxy :: Proxy GhcjsDomSpace) Click (\_ -> preventDefault) def)
165+ & initialAttributes .~ "type" =: "checkbox"
166+ void $ element "input" conf $ text "hello world"
167+ assertEqual "Click not prevented" (False, False) clicked
168+
169+ it "can add/update/remove attributes" $ do
170+ let checkInitialAttrs = do
171+ e <- WD.findElem $ WD.ByTag "div"
172+ assertAttr e "const" (Just "const")
173+ assertAttr e "delete" (Just "delete")
174+ assertAttr e "init" (Just "init")
175+ assertAttr e "click" Nothing
176+ pure e
177+ checkModifyAttrs e = do
178+ WD.click e
179+ liftIO $ threadDelay 100000
180+ assertAttr e "const" (Just "const")
181+ assertAttr e "delete" Nothing
182+ assertAttr e "init" (Just "click")
183+ assertAttr e "click" (Just "click")
184+ testWidget' checkInitialAttrs checkModifyAttrs $ mdo
185+ let conf = def
186+ & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
187+ & modifyAttributes .~ (("delete" =: Nothing <> "init" =: Just "click" <> "click" =: Just "click") <$ click)
188+ (e, ()) <- element "div" conf $ text "hello world"
189+ let click = domEvent Click e
190+ return ()
191+
192+ -- TODO check this is the correct solution
193+ it "has ssr attribute, removes ssr attribute" $ do
194+ let checkSSRAttr = do
195+ e <- WD.findElem $ WD.ByTag "div"
196+ assertAttr e "ssr" (Just "")
197+ pure e
198+ testWidget' checkSSRAttr (\e -> assertAttr e "ssr" Nothing) $ el "div" $ text "hello world"
199+
200+ describe "inputElement" $ parallel $ do
201+ it "doesn't wipe user input when switching over" $ do
202+ inputRef <- newIORef ""
203+ testWidget'
204+ (do
205+ e <- WD.findElem $ WD.ByTag "input"
206+ WD.sendKeys "hello world" e
207+ pure e)
208+ (\e -> do
209+ t <- WD.attr e "value"
210+ liftIO $ t `shouldBe` Just "hello world"
211+ WD.click <=< WD.findElem $ WD.ByTag "button"
212+ input <- liftIO $ readIORef inputRef
213+ liftIO $ input `shouldBe` "hello world"
214+ ) $ do
215+ e <- inputElement def
216+ click <- button "save"
217+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click
218+ it "captures user input after switchover" $ do
219+ inputRef <- newIORef ""
220+ let checkValue = do
221+ WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
222+ WD.click <=< WD.findElem $ WD.ByTag "button"
223+ input <- liftIO $ readIORef inputRef
224+ liftIO $ input `shouldBe` "hello world"
225+ testWidget (pure ()) checkValue $ do
226+ e <- inputElement def
227+ click <- button "save"
228+ performEvent_ $ liftIO . writeIORef inputRef <$> tag (current (value e)) click
229+ it "sets focus appropriately" $ do
230+ focusRef <- newIORef False
231+ let checkValue = do
232+ liftIO $ readIORef focusRef >>= flip shouldBe False
233+ e <- WD.findElem $ WD.ByTag "input"
234+ WD.moveToCenter e
235+ WD.click e
236+ liftIO $ threadDelay 100000
237+ liftIO $ readIORef focusRef >>= flip shouldBe True
238+ testWidget (pure ()) checkValue $ do
239+ e <- inputElement def
240+ performEvent_ $ liftIO . writeIORef focusRef <$> updated (_inputElement_hasFocus e)
241+ it "sets checked appropriately" $ do
242+ checkedByUIRef <- newIORef False
243+ checkedRef <- newIORef False
244+ setCheckedChan <- newChan
245+ let checkValue = do
246+ liftIO $ readIORef checkedByUIRef >>= flip shouldBe False
247+ liftIO $ readIORef checkedRef >>= flip shouldBe False
248+ e <- WD.findElem $ WD.ByTag "input"
249+ WD.moveToCenter e
250+ WD.click e
251+ liftIO $ do
252+ threadDelay 100000
253+ readIORef checkedByUIRef >>= flip shouldBe True
254+ readIORef checkedRef >>= flip shouldBe True
255+ writeChan setCheckedChan False
256+ threadDelay 100000
257+ readIORef checkedByUIRef >>= flip shouldBe True
258+ readIORef checkedRef >>= flip shouldBe False
259+ testWidget (pure ()) checkValue $ do
260+ (setChecked, triggerSetChecked) <- newTriggerEvent
261+ liftIO $ triggerSetChecked False
262+ liftIO $ forkIO $ forever $ do
263+ liftIO $ putStrLn "before"
264+ triggerSetChecked =<< readChan setCheckedChan
265+ liftIO $ putStrLn "after"
266+ performEvent_ $ ffor setChecked $ \c -> do
267+ liftIO $ do
268+ putStrLn "---------------setChecked"
269+ print c
270+ e <- inputElement $ def
271+ & initialAttributes .~ "type" =: "checkbox"
272+ & inputElementConfig_setChecked .~ setChecked
273+ performEvent_ $ liftIO . writeIORef checkedByUIRef <$> _inputElement_checkedChange e
274+ performEvent_ $ liftIO . writeIORef checkedRef <$> updated (_inputElement_checked e)
275+
276+ describe "prerender" $ parallel $ do
277+ it "works in simple case" $ do
278+ testWidget (checkBodyText "One") (checkBodyText "Two") $ do
279+ prerender (text "One") (text "Two")
280+ it "removes element correctly" $ do
281+ testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
282+ prerender (el "span" $ text "One") (text "Two")
283+ it "can be nested in server widget" $ do
284+ testWidget (checkBodyText "One") (checkBodyText "Three") $ do
285+ prerender (prerender (text "One") (text "Two")) (text "Three")
286+ it "can be nested in client widget" $ do
287+ testWidget (checkBodyText "One") (checkBodyText "Three") $ do
288+ prerender (text "One") (prerender (text "Two") (text "Three"))
289+ it "works with prerender siblings" $ do
290+ testWidget
291+ (checkTextInId "a1" "One" >> checkTextInId "b1" "Three" >> checkTextInId "c1" "Five")
292+ (checkTextInId "a2" "Two" >> checkTextInId "b2" "Four" >> checkTextInId "c2" "Six") $ do
293+ prerender (divId "a1" $ text "One") (divId "a2" $ text "Two")
294+ prerender (divId "b1" $ text "Three") (divId "b2" $ text "Four")
295+ prerender (divId "c1" $ text "Five") (divId "c2" $ text "Six")
296+ it "works inside other element" $ do
297+ testWidget (checkTextInTag "div" "One") (checkTextInTag "div" "Two") $ do
298+ el "div" $ prerender (text "One") (text "Two")
299+
300+ it "places fences and removes them" $ do
301+ testWidget'
302+ (do
303+ scripts <- WD.findElems $ WD.ByTag "script"
304+ filterM (\s -> maybe False (\t -> "prerender" `T.isPrefixOf` t) <$> WD.attr s "type") scripts
305+ )
306+ (traverse_ elementShouldBeRemoved)
307+ (el "span" $ prerender (text "One") (text "Two"))
308+
309+assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
310+assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
311+
312+elementShouldBeRemoved :: WD.Element -> WD ()
313+elementShouldBeRemoved e = do
314+ try (WD.getText e) >>= \case
315+ Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
316+ Left e -> throwM e
317+ Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
318+
319+shouldContainText :: WD.Element -> Text -> WD ()
320+shouldContainText e t = liftIO . flip shouldBe t =<< WD.getText e
321+
322+checkBodyText :: Text -> WD ()
323+checkBodyText = checkTextInTag "body"
324+
325+checkTextInTag :: Text -> Text -> WD ()
326+checkTextInTag tag expected = do
327+ body <- WD.findElem $ WD.ByTag tag
328+ body `shouldContainText` expected
329+
330+checkTextInId :: Text -> Text -> WD ()
331+checkTextInId i expected = do
332+ e <- WD.findElem $ WD.ById i
333+ e `shouldContainText` expected
334+
335+divId :: DomBuilder t m => Text -> m a -> m a
336+divId i = elAttr "div" ("id" =: i)
337+
338+type TestWidget js t m = (DomBuilder t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m, MonadIO m)
339+
340+testWidgetStatic
341+ :: WD b
342+ -- ^ Webdriver commands to run before JS runs and after hydration switchover
343+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
344+ -- ^ Widget we are testing
345+ -> IO b
346+testWidgetStatic w = testWidget (void w) w
347+
348+-- | TODO: do something about JSExceptions not causing tests to fail
349+testWidget
350+ :: WD ()
351+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
352+ -> WD b
353+ -- ^ Webdriver commands to run after hydration switchover
354+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
355+ -- ^ Widget we are testing
356+ -> IO b
357+testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
358+
359+-- | TODO: do something about JSExceptions not causing tests to fail
360+testWidget'
361+ :: WD a
362+ -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
363+ -> (a -> WD b)
364+ -- ^ Webdriver commands to run after hydration switchover
365+ -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
366+ -- ^ Widget we are testing (contents of body)
367+ -> IO b
368+testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
369+ let staticApp = do
370+ el "head" $ pure ()
371+ el "body" $ do
372+ bodyWidget
373+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
374+ ((), html) <- renderStatic staticApp
375+ waitBeforeJS <- newEmptyMVar -- Empty until JS should be run
376+ waitUntilSwitchover <- newEmptyMVar -- Empty until switchover
377+ let entryPoint = do
378+ liftIO $ takeMVar waitBeforeJS
379+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) $ bodyWidget
380+ syncPoint
381+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
382+ --port <- randomRIO (3000, 50000)
383+ let port = 3911 -- TODO
384+ let settings = Warp.setPort port Warp.defaultSettings
385+ -- hSilence to get rid of ConnectionClosed logs
386+ jsaddleWarp = forkIO $ Warp.runSettings settings application
387+ bracket jsaddleWarp killThread $ \_ -> do
388+ WD.runSession chromeConfig . WD.finallyClose $ do
389+ WD.openPage $ "http://localhost:" <> show port
390+ a <- beforeJS
391+ liftIO $ putMVar waitBeforeJS ()
392+ liftIO $ takeMVar waitUntilSwitchover
393+ afterSwitchover a