@@ -0,0 +1,93 @@
1+{-# language OverloadedStrings #-}
2+
3+module Servant.ReflexSpec where
4+
5+import Control.Concurrent (threadDelay)
6+import Control.Monad.IO.Class (liftIO)
7+import Data.Monoid ((<>))
8+import qualified Data.Text as T
9+import Data.Foldable
10+import Test.WebDriver.Commands.Wait
11+import Test.Hspec.WebDriver
12+
13+
14+clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
15+clickingShouldCause inp outp timeLimit s = do
16+ inputEl <- findElem inp
17+ outputEl <- findElem outp
18+ click inputEl
19+ _ <- waitUntil timeLimit $ do
20+ r <- s inputEl outputEl
21+ return r
22+ return ()
23+
24+hasInfixText :: Element -> T.Text -> WD Bool
25+hasInfixText el t = getText el >>= \txt -> return $ t `T.isInfixOf` txt
26+
27+spec :: Spec
28+spec = do
29+ describe "servant-reflex tests" $ do
30+
31+ session "test page" $ using Chrome $ do
32+
33+ it "opens the page" $ runWD $
34+ openPage "http://localhost:8000"
35+
36+ it "has a div" $ runWD $ do
37+ e <- waitUntil 5 $ findElem $ ByCSS "div"
38+ e `shouldBeTag` "div"
39+
40+ it "has demo-group div" $ runWD $ do
41+ e <- findElem $ ByCSS "div.demo-group"
42+ e `shouldBeTag` "div"
43+
44+ it "doesn't have demo-group-nonexistent div" $ runWD $ do
45+ e <- findElems $ ByCSS "div.demo-group.nonexistent"
46+ e `shouldBe` []
47+
48+ it "can get an int or unit from the API" $ runWD $ do
49+ let outEl = ByCSS "div.unit-int-response p"
50+ clickingShouldCause (ByCSS "div.int-button > button") outEl 0.1
51+ (\i o -> o `hasInfixText` "Just \"100\"")
52+ clickingShouldCause (ByCSS "div.unit-button > button") outEl 0.1
53+ (\i o -> o `hasInfixText` "Just \"[[]]\"")
54+
55+ let setupGreeting = do
56+ iName <- findElem $ ByCSS ".name-input input"
57+ iGreetings <- findElem $ ByCSS ".greetings-input input"
58+ bGusto <- findElem $ ByCSS ".gusto-input input"
59+ goBtn <- findElem $ ByCSS ".hi-button button"
60+ greetingRes <- findElem $ ByCSS ".greeting-response"
61+ return (iName, iGreetings, bGusto, goBtn, greetingRes)
62+
63+ it "handle query params" $ runWD $ do
64+ (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
65+ sendKeys "Haskell" iName
66+ sendKeys "Hello Hi" iGreetings
67+ click goBtn
68+ greetingRes `shouldHaveText` "Hello, and Hi, Haskell"
69+
70+ it "handles queryflag" $ runWD $ do
71+ (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
72+ click bGusto
73+ click goBtn
74+ greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL"
75+
76+ it "tags dyn promptly" $ runWD $ do
77+ (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
78+ sendKeys "!" iName
79+ greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL!"
80+
81+{- Broken. Why?
82+ it "handles request bodies" $ runWD $ do
83+ dText <- findElem $ ByCSS ".double-input input"
84+ dSend <- findElem $ ByCSS ".double-button button"
85+ dRes <- findElem $ ByCSS ".double-result p"
86+ dErr <- findElem $ ByCSS ".double-errors"
87+ sendKeys "200" dText
88+ click dSend
89+ saveScreenshot "/home/ubuntu/screen.png"
90+ liftIO (threadDelay 1000000)
91+ dErr `shouldHaveText` "(no errors)"
92+ dRes `shouldHaveText` "400.0"
93+-}