@@ -2,68 +2,113 @@
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE CPP #-}
44{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE GADTs #-}
56{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
68{-# LANGUAGE OverloadedStrings #-}
79{-# LANGUAGE RankNTypes #-}
810{-# LANGUAGE RecursiveDo #-}
911{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TypeApplications #-}
1014{-# LANGUAGE TypeFamilies #-}
1115
1216import Control.Concurrent
13−import Control.Lens ((^.))
1417import Control.Monad
1518import Control.Monad.Catch
1619import Control.Monad.Fix
1720import Control.Monad.IO.Class
21+import Data.Constraint (Dict(..))
22+import Data.Constraint.Extras
23+import Data.Dependent.Map (DMap)
24+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
1825import Data.Foldable (traverse_)
26+import Data.Functor.Identity
27+import Data.Functor.Misc
28+import Data.GADT.Compare.TH
29+import Data.GADT.Show.TH
1930import Data.IORef
2031import Data.Map (Map)
21−import Data.Maybe (fromMaybe)
32+import Data.Maybe (fromMaybe, fromJust)
2233import Data.Proxy
2334import Data.Text (Text)
24−import Language.Javascript.JSaddle (JSException(..), syncPoint, liftJSM, jsg, js1)
35+import Language.Javascript.JSaddle (syncPoint, liftJSM)
2536import Language.Javascript.JSaddle.Warp
2637import Network.HTTP.Types (status200)
2738import Network.Wai
2839import Network.WebSockets
29−import Reflex.Dom.Core
3040import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)
41+import Reflex.Dom.Core
42+import System.Directory
43+import System.IO (stderr)
44+import System.IO.Silently
45+import System.IO.Temp
3146import System.Process
32−import System.Random
3347import System.Timeout
34−import Test.Hspec
3548import Test.HUnit
49+import Test.Hspec
3650import Test.WebDriver (WD)
37−import qualified GHCJS.DOM.Types as DOM
38−import qualified GHCJS.DOM.File as File
39−
40−import System.IO (stderr)
41−import System.IO.Silently
42−import System.IO.Temp
43−import System.Directory
44−import qualified System.FilePath as FilePath
4551
52+import qualified Data.ByteString.Lazy as LBS
53+import qualified Data.Dependent.Map as DMap
54+import qualified Data.Text as T
55+import qualified Data.Text.Encoding as TE
4656import qualified GHCJS.DOM as DOM
4757import qualified GHCJS.DOM.Document as Document
4858import qualified GHCJS.DOM.Element as Element
4959import qualified GHCJS.DOM.EventM as EventM
60+import qualified GHCJS.DOM.File as File
5061import qualified GHCJS.DOM.GlobalEventHandlers as Events
5162import qualified GHCJS.DOM.Node as Node
52−import qualified Data.ByteString.Lazy as LBS
53−import qualified Data.Text as T
54−import qualified Data.Text.Encoding as TE
63+import qualified GHCJS.DOM.Types as DOM
5564import qualified Network.Wai.Handler.Warp as Warp
65+import qualified System.FilePath as FilePath
5666import qualified Test.WebDriver as WD
5767
5868testTimeLimit :: Int
59−testTimeLimit = 1 * 1000 * 1000
69+testTimeLimit = 3 * 1000 * 1000
6070
6171chromeConfig :: WD.WDConfig
6272chromeConfig = WD.useBrowser (WD.chrome { WD.chromeBinary = Just "/run/current-system/sw/bin/chromium", WD.chromeOptions = ["--headless"]}) WD.defaultConfig
6373
64−-- TODO list
65−-- use only available ports
66−-- parallel (requires port fix)
74+keyMap :: DMap DKey Identity
75+keyMap = DMap.fromList
76+ [ Key_Int ==> 0
77+ , Key_Char ==> 'A'
78+ ]
79+
80+data DKey a where
81+ Key_Int :: DKey Int
82+ Key_Char :: DKey Char
83+ Key_Bool :: DKey Bool
84+
85+instance ArgDict DKey where
86+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
87+ argDict = \case
88+ Key_Int -> Dict
89+ Key_Char -> Dict
90+ Key_Bool -> Dict
91+
92+textKey :: DKey a -> Text
93+textKey = \case
94+ Key_Int -> "Key_Int"
95+ Key_Char -> "Key_Char"
96+ Key_Bool -> "Key_Bool"
97+
98+deriveGEq ''DKey
99+deriveGCompare ''DKey
100+deriveGShow ''DKey
101+
102+instance ShowTag DKey Identity where
103+ showTaggedPrec = \case
104+ Key_Int -> showsPrec
105+ Key_Char -> showsPrec
106+ Key_Bool -> showsPrec
107+
108+instance EqTag DKey Identity where
109+ eqTagged Key_Int Key_Int = (==)
110+ eqTagged Key_Char Key_Char = (==)
111+ eqTagged Key_Bool Key_Bool = (==)
67112
68113main :: IO ()
69114main = hspec $ beforeAll startSeleniumServer $ do
@@ -134,7 +179,6 @@ main = hspec $ beforeAll startSeleniumServer $ do
134179 testWidgetStatic (pure ()) $ do
135180 text =<< prerender (pure "One") (pure "Two")
136181
137−
138182 describe "element" $ do
139183 it "works with domEvent Click" $ do
140184 clickedRef <- newIORef False
@@ -796,12 +840,247 @@ main = hspec $ beforeAll startSeleniumServer $ do
796840 )
797841 (traverse_ elementShouldBeRemoved)
798842 (el "span" $ prerender (text "One") (text "Two"))
843+-- it "postBuild works on server side" $ do
844+-- pbRef <- newIORef False
845+-- testWidgetStatic (pure ()) $ do
846+-- prerender (do
847+-- pb <- getPostBuild
848+-- performEvent_ $ liftIO (writeIORef pbRef True) <$ pb) blank
849+-- readIORef pbRef >>= (`shouldBe` True)
850+ it "postBuild works on client side" $ do
851+ pbRef <- newIORef False
852+ testWidgetStatic (pure ()) $ do
853+ prerender blank $ do
854+ pb <- getPostBuild
855+ performEvent_ $ liftIO (writeIORef pbRef True) <$ pb
856+ readIORef pbRef >>= (`shouldBe` True)
857+
858+ describe "runWithReplace" $ do
859+ it "works" $ do
860+ replaceChan <- newChan
861+ let setup = WD.findElem $ WD.ByTag "div"
862+ check ssr = do
863+ -- Check that the original element still exists and has the correct text
864+ WD.getText ssr >>= liftIO . flip shouldBe "two"
865+ liftIO $ do
866+ writeChan replaceChan "three"
867+ threadDelay 100000
868+ elementShouldBeRemoved ssr
869+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
870+ testWidget' setup check $ do
871+ replace <- triggerEventWithChan replaceChan
872+ pb <- getPostBuild
873+ runWithReplace (el "div" $ text "one") $ leftmost
874+ [ el "div" (text "two") <$ pb
875+ , el "span" . text <$> replace
876+ ]
877+ return ()
878+ it "can be nested in initial widget" $ do
879+ replaceChan <- newChan
880+ let setup = WD.findElem $ WD.ByTag "div"
881+ check ssr = do
882+ -- Check that the original element still exists and has the correct text
883+ WD.getText ssr >>= liftIO . flip shouldBe "two"
884+ liftIO $ do
885+ writeChan replaceChan "three"
886+ threadDelay 100000
887+ elementShouldBeRemoved ssr
888+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
889+ testWidget' setup check $ void $ flip runWithReplace never $ do
890+ replace <- triggerEventWithChan replaceChan
891+ pb <- getPostBuild
892+ runWithReplace (el "div" $ text "one") $ leftmost
893+ [ el "div" (text "two") <$ pb
894+ , el "span" . text <$> replace
895+ ]
896+ return ()
897+ it "can be nested in postBuild widget" $ do
898+ replaceChan <- newChan
899+ let setup = WD.findElem $ WD.ByTag "div"
900+ check ssr = do
901+ -- Check that the original element still exists and has the correct text
902+ WD.getText ssr >>= liftIO . flip shouldBe "two"
903+ liftIO $ do
904+ writeChan replaceChan "three"
905+ threadDelay 100000
906+ elementShouldBeRemoved ssr
907+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
908+ testWidget' setup check $ void $ do
909+ pb <- getPostBuild
910+ runWithReplace (pure ()) $ ffor pb $ \() -> do
911+ replace <- triggerEventWithChan replaceChan
912+ pb <- getPostBuild
913+ runWithReplace (el "div" $ text "one") $ leftmost
914+ [ el "div" (text "two") <$ pb
915+ , el "span" . text <$> replace
916+ ]
917+ return ()
918+ it "can be nested in event widget" $ do
919+ replaceChan1 <- newChan
920+ replaceChan2 <- newChan
921+ let check = do
922+ shouldContainText "" =<< WD.findElem (WD.ByTag "body")
923+ liftIO $ do
924+ writeChan replaceChan1 "one"
925+ threadDelay 100000
926+ one <- WD.findElem $ WD.ByTag "div"
927+ WD.getText one >>= liftIO . flip shouldBe "pb"
928+ liftIO $ do
929+ writeChan replaceChan2 "two"
930+ threadDelay 100000
931+ elementShouldBeRemoved one
932+ shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
933+ testWidget (pure ()) check $ void $ do
934+ replace1 <- triggerEventWithChan replaceChan1
935+ runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
936+ replace2 <- triggerEventWithChan replaceChan2
937+ pb <- getPostBuild
938+ runWithReplace (el "div" $ text r1) $ leftmost
939+ [ el "span" . text <$> replace2
940+ , el "div" (text "pb") <$ pb
941+ ]
942+ return ()
943+ it "works in immediate mode (RHS of prerender)" $ do
944+ replaceChan :: Chan Text <- newChan
945+ let check = do
946+ one <- WD.findElem $ WD.ByTag "div"
947+ shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
948+ WD.getText one >>= liftIO . flip shouldBe "one"
949+ liftIO $ do
950+ writeChan replaceChan "pb"
951+ threadDelay 100000
952+ elementShouldBeRemoved one
953+ shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
954+ testWidget (pure ()) check $ void $ do
955+ prerender blank $ do
956+ replace <- triggerEventWithChan replaceChan
957+ pb <- getPostBuild
958+ void $ runWithReplace (el "div" $ text "one") $ el "span" . text <$> replace
959+ it "works with postBuild in immediate mode (RHS of prerender)" $ do
960+ replaceChan :: Chan Text <- newChan
961+ let check = do
962+ two <- WD.findElem $ WD.ByTag "div"
963+ shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
964+ WD.getText two >>= liftIO . flip shouldBe "two"
965+ liftIO $ do
966+ writeChan replaceChan "three"
967+ threadDelay 100000
968+ elementShouldBeRemoved two
969+ shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
970+ testWidget (pure ()) check $ void $ do
971+ prerender blank $ do
972+ replace <- triggerEventWithChan replaceChan
973+ pb <- getPostBuild
974+ void $ runWithReplace (el "div" $ text "one") $ leftmost
975+ [ el "div" (text "two") <$ pb
976+ , el "span" . text <$> replace
977+ ]
978+
979+ describe "traverseDMapWithKeyWithAdjust" $ do
980+ let widget :: TestWidget js t m => DKey a -> Identity a -> m (Identity a)
981+ widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
982+ elClass "span" "key" $ text $ textKey k
983+ elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
984+ pure (Identity v)
985+ checkItem :: WD.Element -> Text -> Text -> WD ()
986+ checkItem li k v = do
987+ shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
988+ shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
989+ checkInitialItems dm xs = do
990+ liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
991+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
992+ getAndCheckInitialItems dm = do
993+ xs <- WD.findElems (WD.ByTag "li")
994+ checkInitialItems dm xs
995+ pure xs
996+ checkRemoval chan k = do
997+ e <- WD.findElem (WD.ById $ textKey k)
998+ liftIO $ do
999+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
1000+ threadDelay 100000
1001+ elementShouldBeRemoved e
1002+ checkReplace chan k v = do
1003+ e <- WD.findElem (WD.ById $ textKey k)
1004+ liftIO $ do
1005+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1006+ threadDelay 100000
1007+ elementShouldBeRemoved e
1008+ e' <- WD.findElem (WD.ById $ textKey k)
1009+ checkItem e' (textKey k) (T.pack $ show v)
1010+ checkInsert chan k v = do
1011+ liftIO $ do
1012+ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
1013+ threadDelay 100000
1014+ e <- WD.findElem (WD.ById $ textKey k)
1015+ checkItem e (textKey k) (T.pack $ show v)
1016+ postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
1017+ it "doesn't replace elements at switchover, can delete/update/insert" $ do
1018+ chan <- newChan
1019+ let static = getAndCheckInitialItems keyMap
1020+ check xs = do
1021+ checkInitialItems keyMap xs
1022+ checkRemoval chan Key_Int
1023+ checkReplace chan Key_Char 'B'
1024+ checkInsert chan Key_Bool True
1025+ testWidget' static check $ void $ do
1026+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1027+ liftIO $ dmap `shouldBe` keyMap
1028+ it "handles postBuild correctly" $ do
1029+ chan <- newChan
1030+ let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1031+ check xs = do
1032+ checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
1033+ checkRemoval chan Key_Int
1034+ checkInsert chan Key_Char 'B'
1035+ checkReplace chan Key_Bool True
1036+ testWidget' static check $ void $ do
1037+ pb <- getPostBuild
1038+ replace <- triggerEventWithChan chan
1039+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1040+ liftIO $ dmap `shouldBe` keyMap
1041+ it "can delete/update/insert when built in prerender" $ do
1042+ chan <- newChan
1043+ let check = do
1044+ getAndCheckInitialItems keyMap
1045+ checkRemoval chan Key_Int
1046+ checkReplace chan Key_Char 'B'
1047+ checkInsert chan Key_Bool True
1048+ testWidget (pure ()) check $ prerender (pure ()) $ void $ do
1049+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1050+ liftIO $ dmap `shouldBe` keyMap
1051+ it "can delete/update/insert when built in immediate mode" $ do
1052+ chan <- newChan
1053+ let check = do
1054+ getAndCheckInitialItems keyMap
1055+ checkRemoval chan Key_Int
1056+ checkReplace chan Key_Char 'B'
1057+ checkInsert chan Key_Bool True
1058+ testWidget (pure ()) check $ void $ do
1059+ pb <- getPostBuild
1060+ runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1061+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap =<< triggerEventWithChan chan
1062+ liftIO $ dmap `shouldBe` keyMap
1063+ -- Should be fixed by prerender changes!
1064+ it "handles postBuild correctly in prerender" $ do
1065+ chan <- newChan
1066+ let check = do
1067+ getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1068+ checkRemoval chan Key_Int
1069+ checkInsert chan Key_Char 'B'
1070+ checkReplace chan Key_Bool True
1071+ testWidget (pure ()) check $ do
1072+ replace <- triggerEventWithChan chan
1073+ prerender (pure ()) $ void $ do
1074+ pb <- getPostBuild
1075+ (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1076+ liftIO $ dmap `shouldBe` keyMap
7991077
8001078startSeleniumServer :: IO ()
8011079startSeleniumServer = do
8021080 (_,_,_,ph) <- createProcess $ (proc "selenium-server" [])
8031081 { std_in = NoStream
8041082 , std_out = NoStream
1083+ , std_err = NoStream
8051084 }
8061085 _ <- forkIO $ print =<< waitForProcess ph
8071086 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
@@ -837,7 +1116,7 @@ checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expecte
8371116divId :: DomBuilder t m => Text -> m a -> m a
8381117divId i = elAttr "div" ("id" =: i)
8391118
840−type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m, MonadIO m)
1119+type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadFix m, MonadIO m)
8411120
8421121testWidgetStatic
8431122 :: WD b
@@ -894,3 +1173,17 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
8941173 liftIO $ takeMVar waitUntilSwitchover
8951174 liftIO $ threadDelay 100000 -- wait a bit
8961175 afterSwitchover a
1176+
1177+testWidgetDebug :: (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> IO ()
1178+testWidgetDebug bodyWidget = do
1179+ let staticApp = do
1180+ el "head" $ pure ()
1181+ el "body" $ do
1182+ bodyWidget
1183+ el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1184+ ((), html) <- renderStatic staticApp
1185+ let entryPoint = do
1186+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) $ bodyWidget
1187+ syncPoint
1188+ application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1189+ Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application