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.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)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding (catch)
#endif
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' = waitEither id (\_ -> return)
waitWhile :: SessionState m => Double -> m a -> m ()
waitWhile = waitWhile' 500000
waitWhile' :: SessionState m => Int -> Double -> m a -> m ()
waitWhile' =
waitEither (\_ _ -> return ())
(\retry _ -> retry "waitWhile: action did not fail")
waitEither :: SessionState m =>
((String -> m b) -> String -> m b)
-> ((String -> m b) -> a -> m b)
-> Int -> Double -> m a -> m b
waitEither failure success = wait' handler
where
handler retry wd = do
e <- fmap Right wd `catches` [Handler handleFailedCommand
,Handler handleExpectFailed
]
either (failure retry) (success retry) e
where
handleFailedCommand e@(FailedCommand NoSuchElement _) = return . Left . show $ e
handleFailedCommand err = throwIO err
handleExpectFailed (e :: ExpectFailed) = return . Left . 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