{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables,
GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds, CPP #-}
#ifndef CABAL_BUILD_DEVELOPER
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#endif
module Test.WebDriver.Session
(
WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession
, WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)
, SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory
, withRequestHeaders, withAuthHeaders
) where
import Test.WebDriver.Session.History
import Data.Aeson
import Data.ByteString as BS(ByteString)
import Data.Text (Text)
import Data.Maybe (listToMaybe)
import Data.Monoid
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Error
import Control.Monad.Trans.Except
import Control.Monad.Trans.Writer.Strict as SW
import Control.Monad.Trans.Writer.Lazy as LW
import Control.Monad.Trans.State.Strict as SS
import Control.Monad.Trans.State.Lazy as LS
import Control.Monad.Trans.RWS.Strict as SRWS
import Control.Monad.Trans.RWS.Lazy as LRWS
import Control.Exception.Lifted (SomeException, try, throwIO)
import Network.HTTP.Client (Manager, Request)
import Network.HTTP.Types (RequestHeaders)
import Prelude
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
, wdSessRequestHeaders :: RequestHeaders
, wdSessAuthHeaders :: RequestHeaders
}
type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]
noHistory :: SessionHistoryConfig
noHistory _ _ = []
unlimitedHistory :: SessionHistoryConfig
unlimitedHistory = (:)
onlyMostRecentHistory :: SessionHistoryConfig
onlyMostRecentHistory h _ = [h]
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
mostRecentHistory :: WDSession -> Maybe SessionHistory
mostRecentHistory = listToMaybe . wdSessHist
mostRecentHTTPRequest :: WDSession -> Maybe Request
mostRecentHTTPRequest = fmap histRequest . mostRecentHistory
withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a
withRequestHeaders h m = do
h' <- fmap wdSessRequestHeaders getSession
modifySession $ \s -> s { wdSessRequestHeaders = h }
(a :: Either SomeException a) <- try m
modifySession $ \s -> s { wdSessRequestHeaders = h' }
either throwIO return a
withAuthHeaders :: WDSessionStateControl m => m a -> m a
withAuthHeaders wd = do
authHeaders <- fmap wdSessAuthHeaders getSession
withRequestHeaders authHeaders wd
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 WDSessionState m => WDSessionState (ListT 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 (Monoid w, WDSessionState m) => WDSessionState (SW.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 WDSessionState m => WDSessionState (ExceptT r 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