module Test.WebDriver.Session
(
WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession
, WDSession(..), mkSession, mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)
, SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory
) where
import Test.WebDriver.Config
import Test.WebDriver.Session.History
import Data.Aeson
import Data.ByteString as BS(ByteString)
import Data.Text (Text)
import Data.Maybe (listToMaybe)
import Data.String (fromString)
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Identity
import Control.Monad.List
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Writer.Strict as SW
import Control.Monad.Writer.Lazy as LW
import Control.Monad.State.Strict as SS
import Control.Monad.State.Lazy as LS
import Control.Monad.RWS.Strict as SRWS
import Control.Monad.RWS.Lazy as LRWS
import Control.Exception.Lifted (SomeException, try, throwIO)
import Network.HTTP.Client (Manager, Request, newManager, defaultManagerSettings)
newtype SessionId = SessionId Text
deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)
data WDSession = WDSession {
wdSessHost :: BS.ByteString
, wdSessPort :: Int
, wdSessBasePath :: BS.ByteString
, wdSessId :: Maybe SessionId
, wdSessHist :: [SessionHistory]
, wdSessHistUpdate :: SessionHistoryConfig
, wdSessHTTPManager :: Manager
, wdSessHTTPRetryCount :: Int
}
class (Monad m, Applicative m) => WDSessionState m where
getSession :: m WDSession
putSession :: WDSession -> m ()
type WDSessionStateIO s = (WDSessionState s, MonadBase IO s)
type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s)
modifySession :: WDSessionState s => (WDSession -> WDSession) -> s ()
modifySession f = getSession >>= putSession . f
withSession :: WDSessionStateControl m => WDSession -> m a -> m a
withSession s m = do
s' <- getSession
putSession s
(a :: Either SomeException a) <- try m
putSession s'
either throwIO return a
mkSession :: MonadBase IO m => WDConfig -> m WDSession
mkSession WDConfig{..} = do
manager <- maybe createManager return wdHTTPManager
return WDSession { wdSessHost = fromString $ wdHost
, wdSessPort = wdPort
, wdSessBasePath = fromString $ wdBasePath
, wdSessId = Nothing
, wdSessHist = []
, wdSessHistUpdate = wdHistoryConfig
, wdSessHTTPManager = manager
, wdSessHTTPRetryCount = wdHTTPRetryCount }
where
createManager = liftBase $ newManager defaultManagerSettings
mostRecentHistory :: WDSession -> Maybe SessionHistory
mostRecentHistory = listToMaybe . wdSessHist
mostRecentHTTPRequest :: WDSession -> Maybe Request
mostRecentHTTPRequest = fmap histRequest . mostRecentHistory
instance WDSessionState m => WDSessionState (LS.StateT s m) where
getSession = lift getSession
putSession = lift . putSession
instance WDSessionState m => WDSessionState (SS.StateT s m) where
getSession = lift getSession
putSession = lift . putSession
instance WDSessionState m => WDSessionState (MaybeT m) where
getSession = lift getSession
putSession = lift . putSession
instance WDSessionState m => WDSessionState (IdentityT m) where
getSession = lift getSession
putSession = lift . putSession
instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where
getSession = lift getSession
putSession = lift . putSession
instance WDSessionState m => WDSessionState (ReaderT r m) where
getSession = lift getSession
putSession = lift . putSession
instance (Error e, WDSessionState m) => WDSessionState (ErrorT e m) where
getSession = lift getSession
putSession = lift . putSession
instance (Monoid w, WDSessionState m) => WDSessionState (SRWS.RWST r w s m) where
getSession = lift getSession
putSession = lift . putSession
instance (Monoid w, WDSessionState wd) => WDSessionState (LRWS.RWST r w s wd) where
getSession = lift getSession
putSession = lift . putSession