module Test.WebDriver.Monad
( WD(..), runWD, runSession, withSession, finallyClose, closeOnException, dumpSessionHistory
) where
import Test.WebDriver.Class
import Test.WebDriver.Session
import Test.WebDriver.Config
import Test.WebDriver.Commands
import Test.WebDriver.Internal
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl(..), StM)
import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put)
import Control.Exception.Lifted
import Control.Monad.Catch (MonadThrow, MonadCatch)
import Control.Applicative
newtype WD a = WD (StateT WDSession IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch)
instance MonadBase IO WD where
liftBase = WD . liftBase
instance MonadBaseControl IO WD where
data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a}
liftBaseWith f = WD $
liftBaseWith $ \runInBase ->
f (\(WD sT) -> liftM StWD . runInBase $ sT)
restoreM = WD . restoreM . unStWD
instance WDSessionState WD where
getSession = WD get
putSession = WD . put
instance WebDriver WD where
doCommand method path args =
mkRequest [] method path args
>>= sendHTTPRequest
>>= getJSONResult
>>= either throwIO return
runWD :: WDSession -> WD a -> IO a
runWD sess (WD wd) = evalStateT wd sess
runSession :: WDConfig -> WD a -> IO a
runSession conf wd = do
sess <- mkSession conf
runWD sess $ createSession (wdCapabilities conf) >> wd
withSession :: WDSession -> WD a -> WD a
withSession s' (WD wd) = WD . lift $ evalStateT wd s'
finallyClose:: WebDriver wd => wd a -> wd a
finallyClose wd = closeOnException wd <* closeSession
closeOnException :: WebDriver wd => wd a -> wd a
closeOnException wd = wd `onException` closeSession
dumpSessionHistory :: (MonadIO wd, WebDriver wd) => wd a -> wd a
dumpSessionHistory wd = do
v <- wd
getSession >>= liftIO . print . wdSessHist
return v