{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}

module Test.WebDriver.Waits (
  -- * Wait on expected conditions
  waitUntil
  , waitUntil'
  , waitWhile
  , waitWhile'

  -- * Expected conditions
  , ExpectFailed (..)
  , expect
  , unexpected
  , expectAny
  , expectAll
  , expectNotStale
  , expectAlertOpen
  , catchFailedCommand

  -- ** Convenience functions
  , onTimeout
  ) where

import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import qualified Data.Foldable as F
import qualified Data.List as L
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import GHC.Stack
import Test.WebDriver.Commands
import Test.WebDriver.Exceptions
import Test.WebDriver.Types
import UnliftIO.Exception


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

-- | Throws 'ExpectFailed'. This is nice for writing your own abstractions.
unexpected :: (
  MonadIO m
  )
  => String -- ^ Reason why the expected condition failed.
  -> m a
unexpected :: forall (m :: * -> *) a. MonadIO m => String -> m a
unexpected = ExpectFailed -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ExpectFailed -> m a) -> (String -> ExpectFailed) -> String -> m a
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 :: (MonadIO m) => Bool -> m ()
expect :: forall (m :: * -> *). MonadIO m => Bool -> m ()
expect Bool
b
  | Bool
b = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = String -> m ()
forall (m :: * -> *) a. MonadIO m => 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, MonadIO m) => (a -> m Bool) -> f a -> m ()
expectAny :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadIO m) =>
(a -> m Bool) -> f a -> m ()
expectAny a -> m Bool
p f a
xs = Bool -> m ()
forall (m :: * -> *). MonadIO m => Bool -> m ()
expect (Bool -> m ()) -> ([Bool] -> Bool) -> [Bool] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
F.or ([Bool] -> m ()) -> m [Bool] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> m Bool) -> [a] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m Bool
p (f a -> [a]
forall a. f a -> [a]
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, MonadIO m) => (a -> m Bool) -> f a -> m ()
expectAll :: forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadIO m) =>
(a -> m Bool) -> f a -> m ()
expectAll a -> m Bool
p f a
xs = Bool -> m ()
forall (m :: * -> *). MonadIO m => Bool -> m ()
expect (Bool -> m ()) -> ([Bool] -> Bool) -> [Bool] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
F.and ([Bool] -> m ()) -> m [Bool] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> m Bool) -> [a] -> m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m Bool
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList f a
xs)

-- | 'expect' the given 'Element' to not be stale and return it.
expectNotStale :: (HasCallStack, WebDriver wd) => Element -> wd Element
expectNotStale :: forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Element -> wd Element
expectNotStale Element
e = FailedCommandError -> wd Element -> wd Element
forall (m :: * -> *) a.
MonadUnliftIO m =>
FailedCommandError -> m a -> m a
catchFailedCommand FailedCommandError
StaleElementReference (wd Element -> wd Element) -> wd Element -> wd Element
forall a b. (a -> b) -> a -> b
$ do
    Bool
_ <- Element -> wd Bool
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Element -> wd Bool
isEnabled Element
e -- Any command will force a staleness check
    Element -> wd Element
forall a. a -> wd a
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 :: (HasCallStack, WebDriver wd) => wd Text
expectAlertOpen :: forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd Text
expectAlertOpen = FailedCommandError -> wd Text -> wd Text
forall (m :: * -> *) a.
MonadUnliftIO m =>
FailedCommandError -> m a -> m a
catchFailedCommand FailedCommandError
NoSuchAlert wd Text
forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd Text
getAlertText

-- | Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'.
catchFailedCommand :: (MonadUnliftIO m) => FailedCommandError -> m a -> m a
catchFailedCommand :: forall (m :: * -> *) a.
MonadUnliftIO m =>
FailedCommandError -> m a -> m a
catchFailedCommand FailedCommandError
needle m a
m = m a
m m a -> (FailedCommand -> m a) -> m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` FailedCommand -> m a
forall {m :: * -> *} {a}. MonadIO m => FailedCommand -> m a
handler
  where
    handler :: FailedCommand -> m a
handler e :: FailedCommand
e@(FailedCommand {FailedCommandError
rspError :: FailedCommandError
rspError :: FailedCommand -> FailedCommandError
rspError})
      | FailedCommandError
rspError FailedCommandError -> FailedCommandError -> Bool
forall a. Eq a => a -> a -> Bool
== FailedCommandError
needle = String -> m a
forall (m :: * -> *) a. MonadIO m => String -> m a
unexpected (String -> m a)
-> (FailedCommand -> String) -> FailedCommand -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailedCommand -> String
forall a. Show a => a -> String
show (FailedCommand -> m a) -> FailedCommand -> m a
forall a b. (a -> b) -> a -> b
$ FailedCommand
e
    handler FailedCommand
e = FailedCommand -> m a
forall (m :: * -> *) e a. (MonadIO 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 :: (MonadUnliftIO m, HasCallStack) => Double -> m a -> m a
waitUntil :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Double -> m a -> m a
waitUntil = Int -> Double -> m a -> m a
forall (m :: * -> *) a.
(MonadUnliftIO 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' :: (MonadUnliftIO m, HasCallStack) => Int -> Double -> m a -> m a
waitUntil' :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Int -> Double -> m a -> m a
waitUntil' = ((String -> m a) -> String -> m a)
-> ((String -> m a) -> a -> m a) -> Int -> Double -> m a -> m a
forall (m :: * -> *) b a.
(HasCallStack, MonadUnliftIO m) =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b) -> Int -> Double -> m a -> m b
waitEither (String -> m a) -> String -> m a
forall a. a -> a
id (\String -> m a
_ -> a -> m a
forall a. a -> 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 :: (MonadUnliftIO m, HasCallStack)  => Double -> m a -> m ()
waitWhile :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Double -> m a -> m ()
waitWhile = Int -> Double -> m a -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO 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' :: (MonadUnliftIO m, HasCallStack)  => Int -> Double -> m a -> m ()
waitWhile' :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Int -> Double -> m a -> m ()
waitWhile' =
  ((String -> m ()) -> String -> m ())
-> ((String -> m ()) -> a -> m ()) -> Int -> Double -> m a -> m ()
forall (m :: * -> *) b a.
(HasCallStack, MonadUnliftIO m) =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b) -> Int -> Double -> m a -> m b
waitEither  (\String -> m ()
_ String
_ -> () -> m ()
forall a. a -> m a
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 :: (
  HasCallStack, MonadUnliftIO m
  )
  => ((String -> m b) -> String -> m b) -> ((String -> m b) -> a -> m b)
  -> Int
  -> Double
  -> m a
  -> m b
waitEither :: forall (m :: * -> *) b a.
(HasCallStack, MonadUnliftIO m) =>
((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 = ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b
forall (m :: * -> *) b a.
(HasCallStack, MonadIO m) =>
((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 <- (a -> Either String a) -> m a -> m (Either String a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either String a
forall a b. b -> Either a b
Right m a
wd  m (Either String a)
-> [Handler m (Either String a)] -> m (Either String a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> [Handler m a] -> m a
`catches` [(FailedCommand -> m (Either String a))
-> Handler m (Either String a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler FailedCommand -> m (Either String a)
forall {m :: * -> *} {b}.
MonadIO m =>
FailedCommand -> m (Either String b)
handleFailedCommand
                                  , (ExpectFailed -> m (Either String a))
-> Handler m (Either String a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ExpectFailed -> m (Either String a)
forall {m :: * -> *} {b}.
Monad m =>
ExpectFailed -> m (Either String b)
handleExpectFailed
                                  ]
    (String -> m b) -> (a -> m b) -> Either String a -> m b
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 {FailedCommandError
rspError :: FailedCommand -> FailedCommandError
rspError :: FailedCommandError
rspError})
      | FailedCommandError
rspError FailedCommandError -> FailedCommandError -> Bool
forall a. Eq a => a -> a -> Bool
== FailedCommandError
NoSuchElement = Either String b -> m (Either String b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> (FailedCommand -> Either String b)
-> FailedCommand
-> m (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (FailedCommand -> String) -> FailedCommand -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailedCommand -> String
forall a. Show a => a -> String
show (FailedCommand -> m (Either String b))
-> FailedCommand -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ FailedCommand
e
    handleFailedCommand FailedCommand
err = FailedCommand -> m (Either String b)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO FailedCommand
err

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

wait' :: (
  HasCallStack, MonadIO m
  ) => ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b
wait' :: forall (m :: * -> *) b a.
(HasCallStack, MonadIO m) =>
((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 (UTCTime -> m b) -> m UTCTime -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  where
    timeout :: NominalDiffTime
timeout = Double -> NominalDiffTime
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 <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
startTime NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
timeout
            then
              FailedCommand -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FailedCommand -> m b) -> FailedCommand -> m b
forall a b. (a -> b) -> a -> b
$ FailedCommand {
                rspError :: FailedCommandError
rspError = FailedCommandError
Timeout
                , rspMessage :: Text
rspMessage = Text
"wait': explicit wait timed out (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
why Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
                , rspStacktrace :: Text
rspStacktrace = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CallStack -> String
forall a. Show a => a -> String
show (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)
                , rspData :: Maybe Value
rspData = Maybe Value
forall a. Maybe a
Nothing
                }
            else do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Int -> IO ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> m ()) -> Int -> m ()
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 :: (MonadUnliftIO m) => m a -> m a -> m a
onTimeout :: forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a -> m a
onTimeout m a
m m a
r = m a
m m a -> (FailedCommand -> m a) -> m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` FailedCommand -> m a
handler
  where
    handler :: FailedCommand -> m a
handler (FailedCommand {FailedCommandError
rspError :: FailedCommand -> FailedCommandError
rspError :: FailedCommandError
rspError})
      | FailedCommandError
rspError FailedCommandError -> [FailedCommandError] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [FailedCommandError
Timeout, FailedCommandError
ScriptTimeout] = m a
r
    handler FailedCommand
other = FailedCommand -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO FailedCommand
other