{-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, CPP, UndecidableInstances, 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.Monad.IO.Class (MonadIO)
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))