{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}

module Test.WebDriver.Monad (
  WD(..)
  , runWD
  , runSession
  , finallyClose
  , closeOnException
  , getSessionHistory
  , dumpSessionHistory
  ) where

import Test.WebDriver.Class
import Test.WebDriver.Commands
import Test.WebDriver.Config
import Test.WebDriver.Internal
import Test.WebDriver.Session

import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Control (MonadBaseControl(..), StM)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)
import Control.Exception.Lifted
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Applicative

import Prelude -- hides some "unused import" warnings


{- | A state monad for WebDriver commands. -}
newtype WD a = WD (StateT WDSession IO a)
  deriving (forall a b. a -> WD b -> WD a
forall a b. (a -> b) -> WD a -> WD b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WD b -> WD a
$c<$ :: forall a b. a -> WD b -> WD a
fmap :: forall a b. (a -> b) -> WD a -> WD b
$cfmap :: forall a b. (a -> b) -> WD a -> WD b
Functor, Functor WD
forall a. a -> WD a
forall a b. WD a -> WD b -> WD a
forall a b. WD a -> WD b -> WD b
forall a b. WD (a -> b) -> WD a -> WD b
forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. WD a -> WD b -> WD a
$c<* :: forall a b. WD a -> WD b -> WD a
*> :: forall a b. WD a -> WD b -> WD b
$c*> :: forall a b. WD a -> WD b -> WD b
liftA2 :: forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
$cliftA2 :: forall a b c. (a -> b -> c) -> WD a -> WD b -> WD c
<*> :: forall a b. WD (a -> b) -> WD a -> WD b
$c<*> :: forall a b. WD (a -> b) -> WD a -> WD b
pure :: forall a. a -> WD a
$cpure :: forall a. a -> WD a
Applicative, Applicative WD
forall a. a -> WD a
forall a b. WD a -> WD b -> WD b
forall a b. WD a -> (a -> WD b) -> WD b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> WD a
$creturn :: forall a. a -> WD a
>> :: forall a b. WD a -> WD b -> WD b
$c>> :: forall a b. WD a -> WD b -> WD b
>>= :: forall a b. WD a -> (a -> WD b) -> WD b
$c>>= :: forall a b. WD a -> (a -> WD b) -> WD b
Monad, Monad WD
forall a. IO a -> WD a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> WD a
$cliftIO :: forall a. IO a -> WD a
MonadIO, Monad WD
forall e a. Exception e => e -> WD a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> WD a
$cthrowM :: forall e a. Exception e => e -> WD a
MonadThrow, MonadThrow WD
forall e a. Exception e => WD a -> (e -> WD a) -> WD a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a. Exception e => WD a -> (e -> WD a) -> WD a
$ccatch :: forall e a. Exception e => WD a -> (e -> WD a) -> WD a
MonadCatch, Monad WD
forall a. (a -> WD a) -> WD a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> WD a) -> WD a
$cmfix :: forall a. (a -> WD a) -> WD a
MonadFix, MonadCatch WD
forall b. ((forall a. WD a -> WD a) -> WD b) -> WD b
forall a b c.
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
$cgeneralBracket :: forall a b c.
WD a -> (a -> ExitCase b -> WD c) -> (a -> WD b) -> WD (b, c)
uninterruptibleMask :: forall b. ((forall a. WD a -> WD a) -> WD b) -> WD b
$cuninterruptibleMask :: forall b. ((forall a. WD a -> WD a) -> WD b) -> WD b
mask :: forall b. ((forall a. WD a -> WD a) -> WD b) -> WD b
$cmask :: forall b. ((forall a. WD a -> WD a) -> WD b) -> WD b
MonadMask)

instance MonadBase IO WD where
  liftBase :: forall a. IO a -> WD a
liftBase = forall a. StateT WDSession IO a -> WD a
WD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadBaseControl IO WD where
#if MIN_VERSION_monad_control(1,0,0)
  type StM WD a = StM (StateT WDSession IO) a

  liftBaseWith :: forall a. (RunInBase WD IO -> IO a) -> WD a
liftBaseWith RunInBase WD IO -> IO a
f = forall a. StateT WDSession IO a -> WD a
WD forall a b. (a -> b) -> a -> b
$
    forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase (StateT WDSession IO) IO
runInBase ->
    RunInBase WD IO -> IO a
f (\(WD StateT WDSession IO a
sT) -> RunInBase (StateT WDSession IO) IO
runInBase forall a b. (a -> b) -> a -> b
$ StateT WDSession IO a
sT)

  restoreM :: forall a. StM WD a -> WD a
restoreM = forall a. StateT WDSession IO a -> WD a
WD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM
#else
  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
#endif

instance WDSessionState WD where
  getSession :: WD WDSession
getSession = forall a. StateT WDSession IO a -> WD a
WD forall (m :: * -> *) s. Monad m => StateT s m s
get
  putSession :: WDSession -> WD ()
putSession = forall a. StateT WDSession IO a -> WD a
WD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put

instance WebDriver WD where
  doCommand :: forall a b.
(HasCallStack, ToJSON a, FromJSON b) =>
Method -> Text -> a -> WD b
doCommand Method
method Text
path a
args =
    forall (s :: * -> *) a.
(WDSessionState s, ToJSON a) =>
Method -> Text -> a -> s Request
mkRequest Method
method Text
path a
args
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: * -> *).
WDSessionStateIO s =>
Request -> s (Either SomeException (Response ByteString))
sendHTTPRequest
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: * -> *) a.
(HasCallStack, WDSessionStateControl s, FromJSON a) =>
Response ByteString -> s (Either SomeException a)
getJSONResult
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return

-- |Executes a 'WD' computation within the 'IO' monad, using the given
-- 'WDSession' as state for WebDriver requests.
runWD :: WDSession -> WD a -> IO a
runWD :: forall a. WDSession -> WD a -> IO a
runWD WDSession
sess (WD StateT WDSession IO a
wd) = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT WDSession IO a
wd WDSession
sess

-- |Executes a 'WD' computation within the 'IO' monad, automatically creating a new session beforehand.
--
-- NOTE: session is not automatically closed when complete. If you want this behavior, use 'finallyClose'.
-- Example:
--
-- >    runSessionThenClose action = runSession myConfig . finallyClose $ action
runSession :: WebDriverConfig conf => conf -> WD a -> IO a
runSession :: forall conf a. WebDriverConfig conf => conf -> WD a -> IO a
runSession conf
conf WD a
wd = do
  WDSession
sess <- forall c (m :: * -> *).
(WebDriverConfig c, MonadBase IO m) =>
c -> m WDSession
mkSession conf
conf
  Capabilities
caps <- forall c (m :: * -> *).
(WebDriverConfig c, MonadBase IO m) =>
c -> m Capabilities
mkCaps conf
conf
  forall a. WDSession -> WD a -> IO a
runWD WDSession
sess forall a b. (a -> b) -> a -> b
$ forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Capabilities -> wd WDSession
createSession Capabilities
caps forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WD a
wd

-- |A finalizer ensuring that the session is always closed at the end of
-- the given 'WD' action, regardless of any exceptions.
finallyClose:: WebDriver wd => wd a -> wd a
finallyClose :: forall (wd :: * -> *) a. WebDriver wd => wd a -> wd a
finallyClose wd a
wd = forall (wd :: * -> *) a. WebDriver wd => wd a -> wd a
closeOnException wd a
wd forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd ()
closeSession

-- |Exception handler that closes the session when an
-- asynchronous exception is thrown, but otherwise leaves the session open
-- if the action was successful.
closeOnException :: WebDriver wd => wd a -> wd a
closeOnException :: forall (wd :: * -> *) a. WebDriver wd => wd a -> wd a
closeOnException wd a
wd = wd a
wd forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`onException` forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd ()
closeSession

-- |Gets the command history for the current session.
getSessionHistory :: WDSessionState wd => wd [SessionHistory]
getSessionHistory :: forall (wd :: * -> *). WDSessionState wd => wd [SessionHistory]
getSessionHistory = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WDSession -> [SessionHistory]
wdSessHist forall (m :: * -> *). WDSessionState m => m WDSession
getSession

-- |Prints a history of API requests to stdout after computing the given action.
dumpSessionHistory :: WDSessionStateControl wd => wd a -> wd a
dumpSessionHistory :: forall (wd :: * -> *) a. WDSessionStateControl wd => wd a -> wd a
dumpSessionHistory = (forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` (forall (m :: * -> *). WDSessionState m => m WDSession
getSession forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> IO ()
print forall b c a. (b -> c) -> (a -> b) -> a -> c
. WDSession -> [SessionHistory]
wdSessHist))