{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ConstraintKinds #-}

module Test.WebDriver.Commands.Wait
       ( -- * Wait on expected conditions
         waitUntil, waitUntil'
       , waitWhile, waitWhile'
         -- * Expected conditions
       , ExpectFailed (..), expect, unexpected
       , expectAny, expectAll
       , expectNotStale, expectAlertOpen
       , catchFailedCommand
         -- ** Convenience functions
       , onTimeout
       ) where
import Test.WebDriver.Commands
import Test.WebDriver.Class
import Test.WebDriver.Exceptions
import Test.WebDriver.Session

import Control.Concurrent
import Control.Exception.Lifted
import Control.Monad.Base
import Control.Monad.Trans.Control

import Data.CallStack
import qualified Data.Foldable as F
import Data.Text (Text)
import Data.Time.Clock
import Data.Typeable

#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding (catch)
#endif

instance Exception ExpectFailed
-- |An exception representing the failure of an expected condition.
data ExpectFailed = ExpectFailed String deriving (Int -> ExpectFailed -> ShowS
[ExpectFailed] -> ShowS
ExpectFailed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpectFailed] -> ShowS
$cshowList :: [ExpectFailed] -> ShowS
show :: ExpectFailed -> String
$cshow :: ExpectFailed -> String
showsPrec :: Int -> ExpectFailed -> ShowS
$cshowsPrec :: Int -> ExpectFailed -> ShowS
Show, ExpectFailed -> ExpectFailed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpectFailed -> ExpectFailed -> Bool
$c/= :: ExpectFailed -> ExpectFailed -> Bool
== :: ExpectFailed -> ExpectFailed -> Bool
$c== :: ExpectFailed -> ExpectFailed -> Bool
Eq, Typeable)

-- |throws 'ExpectFailed'. This is nice for writing your own abstractions.
unexpected :: (MonadBaseControl IO m, HasCallStack) =>
              String -- ^ Reason why the expected condition failed.
           -> m a
unexpected :: forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
String -> m a
unexpected = forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExpectFailed
ExpectFailed

-- |An expected condition. This function allows you to express assertions in
-- your explicit wait. This function raises 'ExpectFailed' if the given
-- boolean is False, and otherwise does nothing.
expect :: (MonadBaseControl IO m, HasCallStack) => Bool -> m ()
expect :: forall (m :: * -> *).
(MonadBaseControl IO m, HasCallStack) =>
Bool -> m ()
expect Bool
b
  | Bool
b         = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
String -> m a
unexpected String
"Test.WebDriver.Commands.Wait.expect"

-- |Apply a monadic predicate to every element in a list, and 'expect' that
-- at least one succeeds.
expectAny :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()
expectAny :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadBaseControl IO m, HasCallStack) =>
(a -> m Bool) -> f a -> m ()
expectAny a -> m Bool
p f a
xs = forall (m :: * -> *).
(MonadBaseControl IO m, HasCallStack) =>
Bool -> m ()
expect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Bool -> Bool
F.or forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m Bool
p (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f a
xs)

-- |Apply a monadic predicate to every element in a list, and 'expect' that all
-- succeed.
expectAll :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()
expectAll :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadBaseControl IO m, HasCallStack) =>
(a -> m Bool) -> f a -> m ()
expectAll a -> m Bool
p f a
xs = forall (m :: * -> *).
(MonadBaseControl IO m, HasCallStack) =>
Bool -> m ()
expect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Bool -> Bool
F.and forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m Bool
p (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f a
xs)

-- | 'expect' the given 'Element' to not be stale and returns it
expectNotStale :: (WebDriver wd, HasCallStack) => Element -> wd Element
expectNotStale :: forall (wd :: * -> *).
(WebDriver wd, HasCallStack) =>
Element -> wd Element
expectNotStale Element
e = forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
FailedCommandType -> m a -> m a
catchFailedCommand FailedCommandType
StaleElementReference forall a b. (a -> b) -> a -> b
$ do
    Bool
_ <- forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Element -> wd Bool
isEnabled Element
e -- Any command will force a staleness check
    forall (m :: * -> *) a. Monad m => a -> m a
return Element
e

-- | 'expect' an alert to be present on the page, and returns its text.
expectAlertOpen :: (WebDriver wd, HasCallStack) => wd Text
expectAlertOpen :: forall (wd :: * -> *). (WebDriver wd, HasCallStack) => wd Text
expectAlertOpen = forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
FailedCommandType -> m a -> m a
catchFailedCommand FailedCommandType
NoAlertOpen forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd Text
getAlertText

-- |Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'
catchFailedCommand :: (MonadBaseControl IO m, HasCallStack) => FailedCommandType -> m a -> m a
catchFailedCommand :: forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
FailedCommandType -> m a -> m a
catchFailedCommand FailedCommandType
t1 m a
m = m a
m forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a}.
MonadBaseControl IO m =>
FailedCommand -> m a
handler
    where
        handler :: FailedCommand -> m a
handler e :: FailedCommand
e@(FailedCommand FailedCommandType
t2 FailedCommandInfo
_)
            | FailedCommandType
t1 forall a. Eq a => a -> a -> Bool
== FailedCommandType
t2 = forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
String -> m a
unexpected forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ FailedCommand
e
        handler FailedCommand
e = forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO FailedCommand
e

-- |Wait until either the given action succeeds or the timeout is reached.
-- The action will be retried every .5 seconds until no 'ExpectFailed' or
-- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached,
-- then a 'Timeout' exception will be raised. The timeout value
-- is expressed in seconds.
waitUntil :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m a
waitUntil :: forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Double -> m a -> m a
waitUntil = forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Int -> Double -> m a -> m a
waitUntil' Int
500000

-- |Similar to 'waitUntil' but allows you to also specify the poll frequency
-- of the 'WD' action. The frequency is expressed as an integer in microseconds.
waitUntil' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m a
waitUntil' :: forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Int -> Double -> m a -> m a
waitUntil' = forall (m :: * -> *) b a.
(WDSessionStateControl m, HasCallStack) =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b) -> Int -> Double -> m a -> m b
waitEither forall a. a -> a
id (\String -> m a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return)

-- |Like 'waitUntil', but retries the action until it fails or until the timeout
-- is exceeded.
waitWhile :: (WDSessionStateControl m, HasCallStack)  => Double -> m a -> m ()
waitWhile :: forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Double -> m a -> m ()
waitWhile = forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Int -> Double -> m a -> m ()
waitWhile' Int
500000

-- |Like 'waitUntil'', but retries the action until it either fails or
-- until the timeout is exceeded.
waitWhile' :: (WDSessionStateControl m, HasCallStack)  => Int -> Double -> m a -> m ()
waitWhile' :: forall (m :: * -> *) a.
(WDSessionStateControl m, HasCallStack) =>
Int -> Double -> m a -> m ()
waitWhile' =
  forall (m :: * -> *) b a.
(WDSessionStateControl m, HasCallStack) =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b) -> Int -> Double -> m a -> m b
waitEither  (\String -> m ()
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (\String -> m ()
retry a
_ -> String -> m ()
retry String
"waitWhile: action did not fail")


-- |Internal function used to implement explicit wait commands using success and failure continuations
waitEither :: (WDSessionStateControl m, HasCallStack) =>
               ((String -> m b) -> String -> m b)
            -> ((String -> m b) -> a -> m b)
            -> Int -> Double -> m a -> m b
waitEither :: forall (m :: * -> *) b a.
(WDSessionStateControl m, HasCallStack) =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b) -> Int -> Double -> m a -> m b
waitEither (String -> m b) -> String -> m b
failure (String -> m b) -> a -> m b
success = forall (m :: * -> *) b a.
(WDSessionStateIO m, HasCallStack) =>
((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b
wait' (String -> m b) -> m a -> m b
handler
 where
  handler :: (String -> m b) -> m a -> m b
handler String -> m b
retry m a
wd = do
    Either String a
e <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right m a
wd  forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
`catches` [forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall {m :: * -> *} {b}.
MonadBase IO m =>
FailedCommand -> m (Either String b)
handleFailedCommand
                                  ,forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall {m :: * -> *} {b}.
Monad m =>
ExpectFailed -> m (Either String b)
handleExpectFailed
                                  ]
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String -> m b) -> String -> m b
failure String -> m b
retry) ((String -> m b) -> a -> m b
success String -> m b
retry) Either String a
e
   where
    handleFailedCommand :: FailedCommand -> m (Either String b)
handleFailedCommand e :: FailedCommand
e@(FailedCommand FailedCommandType
NoSuchElement FailedCommandInfo
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ FailedCommand
e
    handleFailedCommand FailedCommand
err = forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO FailedCommand
err

    handleExpectFailed :: ExpectFailed -> m (Either String b)
handleExpectFailed (ExpectFailed
e :: ExpectFailed) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ExpectFailed
e

wait' :: (WDSessionStateIO m, HasCallStack) =>
         ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b
wait' :: forall (m :: * -> *) b a.
(WDSessionStateIO m, HasCallStack) =>
((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b
wait' (String -> m b) -> m a -> m b
handler Int
waitAmnt Double
t m a
wd = UTCTime -> m b
waitLoop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime
  where
    timeout :: NominalDiffTime
timeout = forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
t
    waitLoop :: UTCTime -> m b
waitLoop UTCTime
startTime = (String -> m b) -> m a -> m b
handler String -> m b
retry m a
wd
      where
        retry :: String -> m b
retry String
why = do
          UTCTime
now <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime
          if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
startTime forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
timeout
            then
              forall (s :: * -> *) a.
(HasCallStack, WDSessionStateIO s) =>
FailedCommandType -> String -> s a
failedCommand FailedCommandType
Timeout forall a b. (a -> b) -> a -> b
$ String
"wait': explicit wait timed out (" forall a. [a] -> [a] -> [a]
++ String
why forall a. [a] -> [a] -> [a]
++ String
")."
            else do
              forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
waitAmnt
              UTCTime -> m b
waitLoop UTCTime
startTime

-- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions
-- and perform some action.
--
-- Example:
--
-- > waitUntil 5 (getText <=< findElem $ ByCSS ".class")
-- >    `onTimeout` return ""
onTimeout :: (MonadBaseControl IO m, HasCallStack) => m a -> m a -> m a
onTimeout :: forall (m :: * -> *) a.
(MonadBaseControl IO m, HasCallStack) =>
m a -> m a -> m a
onTimeout m a
m m a
r = m a
m forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` FailedCommand -> m a
handler
  where
    handler :: FailedCommand -> m a
handler (FailedCommand FailedCommandType
Timeout FailedCommandInfo
_) = m a
r
    handler FailedCommand
other = forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO FailedCommand
other