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 String deriving (Show, Eq, Typeable)
unexpected :: MonadBaseControl IO m =>
String
-> m a
unexpected = throwIO . ExpectFailed
expect :: MonadBaseControl IO m => Bool -> m ()
expect b
| b = return ()
| otherwise = unexpected "Test.WebDriver.Commands.Wait.expect"
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 e@(FailedCommand NoSuchElement _) = retry (show e)
handleFailedCommand err = throwIO err
handleExpectFailed (e :: ExpectFailed) = retry (show e)
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 Nothing) `catches` [Handler handleFailedCommand
,Handler handleExpectFailed
]
maybe (return ()) retry b
where
handleFailedCommand e@(FailedCommand NoSuchElement _) = return (Just $ show e)
handleFailedCommand err = throwIO err
handleExpectFailed (e :: ExpectFailed) = return (Just $ show e)
wait' :: SessionState m =>
((String -> 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 why = do
now <- liftBase getCurrentTime
if diffUTCTime now startTime >= timeout
then
failedCommand Timeout $
"wait': explicit wait timed out (" ++ why ++ ")."
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