module Test.WebDriver.Commands.Wait
(
waitUntil, waitUntil'
, waitWhile, waitWhile'
, ExpectFailed, expect, unexpected
, onTimeout
, expectAny, expectAll
, ifM, (<||>), (<&&>), notM
) where
import Test.WebDriver.Exceptions
import Test.WebDriver.Classes
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Exception.Lifted
import Control.Concurrent
import Data.Time.Clock
import Data.Typeable
import Control.Conditional (ifM, (<||>), (<&&>), notM)
import Prelude hiding (catch)
instance Exception ExpectFailed
data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable)
unexpected :: MonadBaseControl IO m => m a
unexpected = throwIO ExpectFailed
expect :: MonadBaseControl IO m => Bool -> m ()
expect b
| b = return ()
| otherwise = unexpected
expectAny :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m ()
expectAny p xs = expect . or =<< mapM p xs
expectAll :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m ()
expectAll p xs = expect . and =<< mapM p xs
waitUntil :: SessionState m => Double -> m a -> m a
waitUntil = waitUntil' 500000
waitUntil' :: SessionState m => Int -> Double -> m a -> m a
waitUntil' = wait' handler
where
handler retry = (`catches` [Handler handleFailedCommand
,Handler handleExpectFailed]
)
where
handleFailedCommand (FailedCommand NoSuchElement _) = retry
handleFailedCommand err = throwIO err
handleExpectFailed (_ :: ExpectFailed) = retry
waitWhile :: SessionState m => Double -> m a -> m ()
waitWhile = waitWhile' 500000
waitWhile' :: SessionState m => Int -> Double -> m a -> m ()
waitWhile' = wait' handler
where
handler retry wd = do
b <- (wd >> return True) `catches` [Handler handleFailedCommand
,Handler handleExpectFailed
]
when b retry
where
handleFailedCommand (FailedCommand NoSuchElement _) = return False
handleFailedCommand err = throwIO err
handleExpectFailed (_ :: ExpectFailed) = return False
wait' :: SessionState m =>
(m b -> m a -> m b) -> Int -> Double -> m a -> m b
wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime
where timeout = realToFrac t
waitLoop startTime = handler retry wd
where
retry = do
now <- liftBase getCurrentTime
if diffUTCTime now startTime >= timeout
then
failedCommand Timeout "wait': explicit wait timed out."
else do
liftBase . threadDelay $ waitAmnt
waitLoop startTime
onTimeout :: MonadBaseControl IO m => m a -> m a -> m a
onTimeout m r = m `catch` handler
where
handler (FailedCommand Timeout _) = r
handler other = throwIO other