{-# language OverloadedStrings #-}

module Servant.ReflexSpec where

import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Foldable
import Test.WebDriver.Commands.Wait
import Test.Hspec.WebDriver


clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
clickingShouldCause inp outp timeLimit s = do
  inputEl  <- findElem inp
  outputEl <- findElem outp
  click inputEl
  _ <- waitUntil timeLimit $ do
    r <- s inputEl outputEl
    return r
  return ()

hasInfixText :: Element -> T.Text -> WD Bool
hasInfixText el t = getText el >>= \txt -> return $ t `T.isInfixOf` txt

spec :: Spec
spec = do
  describe "servant-reflex tests" $ do

    session "test page" $ using Chrome $ do

      it "opens the page" $ runWD $
        openPage "http://localhost:8000"

      it "has a div" $ runWD $ do
        e <- waitUntil 5 $ findElem $ ByCSS "div"
        e `shouldBeTag` "div"

      it "has demo-group div" $ runWD $ do
        e <- findElem $ ByCSS "div.demo-group"
        e `shouldBeTag` "div"

      it "doesn't have demo-group-nonexistent div" $ runWD $ do
        e <- findElems $ ByCSS "div.demo-group.nonexistent"
        e `shouldBe` []

      it "can get an int or unit from the API" $ runWD $ do
        let outEl = ByCSS "div.unit-int-response p"
        clickingShouldCause (ByCSS "div.int-button > button") outEl 0.1
          (\i o -> o `hasInfixText` "Just \"100\"")
        clickingShouldCause (ByCSS "div.unit-button > button") outEl 0.1
          (\i o -> o `hasInfixText` "Just \"[[]]\"")

      let setupGreeting = do
            iName       <- findElem $ ByCSS ".name-input input"
            iGreetings  <- findElem $ ByCSS ".greetings-input input"
            bGusto      <- findElem $ ByCSS ".gusto-input input"
            goBtn       <- findElem $ ByCSS ".hi-button button"
            greetingRes <- findElem $ ByCSS ".greeting-response"
            return (iName, iGreetings, bGusto, goBtn, greetingRes)

      it "handle query params" $ runWD $ do
        (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
        sendKeys "Haskell" iName
        sendKeys "Hello Hi" iGreetings
        click goBtn
        greetingRes `shouldHaveText` "Hello, and Hi, Haskell"

      it "handles queryflag" $ runWD $ do
        (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
        click bGusto
        click goBtn
        greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL"

      it "tags dyn promptly" $ runWD $ do
        (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
        sendKeys "!" iName
        greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL!"

{- Broken. Why?
      it "handles request bodies" $ runWD $ do
        dText <- findElem $ ByCSS ".double-input input"
        dSend <- findElem $ ByCSS ".double-button button"
        dRes  <- findElem $ ByCSS ".double-result p"
        dErr  <- findElem $ ByCSS ".double-errors"
        sendKeys "200" dText
        click dSend
        saveScreenshot "/home/ubuntu/screen.png"
        liftIO (threadDelay 1000000)
        dErr `shouldHaveText` "(no errors)"
        dRes `shouldHaveText` "400.0"
-}
