{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}

module Test.WebDriver.Session (
  -- * WDSessionState class
  WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession
  -- ** WebDriver sessions
  , WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)
  -- * SessionHistoryConfig options
  , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory
  -- * Using custom HTTP request headers
  , 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.Cont
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.Types.Header (RequestHeaders)
import Network.HTTP.Client (Manager, Request)
import Network.HTTP.Types (RequestHeaders)

import Prelude -- hides some "redundant import" warnings

{- |An opaque identifier for a WebDriver session. These handles are produced by
the server on session creation, and act to identify a session in progress. -}
newtype SessionId = SessionId Text
                  deriving (SessionId -> SessionId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionId -> SessionId -> Bool
$c/= :: SessionId -> SessionId -> Bool
== :: SessionId -> SessionId -> Bool
$c== :: SessionId -> SessionId -> Bool
Eq, Eq SessionId
SessionId -> SessionId -> Bool
SessionId -> SessionId -> Ordering
SessionId -> SessionId -> SessionId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SessionId -> SessionId -> SessionId
$cmin :: SessionId -> SessionId -> SessionId
max :: SessionId -> SessionId -> SessionId
$cmax :: SessionId -> SessionId -> SessionId
>= :: SessionId -> SessionId -> Bool
$c>= :: SessionId -> SessionId -> Bool
> :: SessionId -> SessionId -> Bool
$c> :: SessionId -> SessionId -> Bool
<= :: SessionId -> SessionId -> Bool
$c<= :: SessionId -> SessionId -> Bool
< :: SessionId -> SessionId -> Bool
$c< :: SessionId -> SessionId -> Bool
compare :: SessionId -> SessionId -> Ordering
$ccompare :: SessionId -> SessionId -> Ordering
Ord, Int -> SessionId -> ShowS
[SessionId] -> ShowS
SessionId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionId] -> ShowS
$cshowList :: [SessionId] -> ShowS
show :: SessionId -> String
$cshow :: SessionId -> String
showsPrec :: Int -> SessionId -> ShowS
$cshowsPrec :: Int -> SessionId -> ShowS
Show, ReadPrec [SessionId]
ReadPrec SessionId
Int -> ReadS SessionId
ReadS [SessionId]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SessionId]
$creadListPrec :: ReadPrec [SessionId]
readPrec :: ReadPrec SessionId
$creadPrec :: ReadPrec SessionId
readList :: ReadS [SessionId]
$creadList :: ReadS [SessionId]
readsPrec :: Int -> ReadS SessionId
$creadsPrec :: Int -> ReadS SessionId
Read, Value -> Parser [SessionId]
Value -> Parser SessionId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SessionId]
$cparseJSONList :: Value -> Parser [SessionId]
parseJSON :: Value -> Parser SessionId
$cparseJSON :: Value -> Parser SessionId
FromJSON, [SessionId] -> Encoding
[SessionId] -> Value
SessionId -> Encoding
SessionId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SessionId] -> Encoding
$ctoEncodingList :: [SessionId] -> Encoding
toJSONList :: [SessionId] -> Value
$ctoJSONList :: [SessionId] -> Value
toEncoding :: SessionId -> Encoding
$ctoEncoding :: SessionId -> Encoding
toJSON :: SessionId -> Value
$ctoJSON :: SessionId -> Value
ToJSON)

{- |The local state of a WebDriver session. This structure is passed
implicitly through all 'WD' computations -}
data WDSession = WDSession {
                             -- server hostname
                             WDSession -> ByteString
wdSessHost :: BS.ByteString
                             -- server port
                           , WDSession -> Int
wdSessPort :: Int
                             -- Base path for API requests
                           , WDSession -> ByteString
wdSessBasePath :: BS.ByteString
                             -- |An opaque reference identifying the session to
                             -- use with 'WD' commands.
                             -- A value of Nothing indicates that a session
                             -- hasn't been created yet.
                             -- Sessions can be created within 'WD' via
                             -- 'Test.WebDriver.createSession', or created
                             -- automatically with 'Test.WebDriver.runSession'
                           , WDSession -> Maybe SessionId
wdSessId   :: Maybe SessionId
                             -- |The complete history of HTTP requests and
                             -- responses, most recent first.
                           , WDSession -> [SessionHistory]
wdSessHist :: [SessionHistory]
                             -- |Update function used to append new entries to session history
                           , WDSession -> SessionHistoryConfig
wdSessHistUpdate :: SessionHistoryConfig
                             -- |HTTP 'Manager' used for connection pooling by the http-client library.
                           , WDSession -> Manager
wdSessHTTPManager :: Manager
                             -- |Number of times to retry a HTTP request if it times out
                           , WDSession -> Int
wdSessHTTPRetryCount :: Int
                             -- |Custom request headers to add to every HTTP request.
                           , WDSession -> RequestHeaders
wdSessRequestHeaders :: RequestHeaders
                             -- |Custom request headers to add *only* to session creation requests. This is usually done
                             --  when a WebDriver server requires HTTP auth.
                           , WDSession -> RequestHeaders
wdSessAuthHeaders :: RequestHeaders
                           }


-- |A function used by 'wdHistoryConfig' to append new entries to session history.
type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]

-- |No session history is saved.
noHistory :: SessionHistoryConfig
noHistory :: SessionHistoryConfig
noHistory SessionHistory
_ [SessionHistory]
_ = []

-- |Keep unlimited history
unlimitedHistory :: SessionHistoryConfig
unlimitedHistory :: SessionHistoryConfig
unlimitedHistory = (:)

-- |Saves only the most recent history
onlyMostRecentHistory :: SessionHistoryConfig
onlyMostRecentHistory :: SessionHistoryConfig
onlyMostRecentHistory SessionHistory
h [SessionHistory]
_ = [SessionHistory
h]

-- |A class for monads that carry a WebDriver session with them. The
-- MonadBaseControl superclass is used for exception handling through
-- the lifted-base package.
class (Monad m, Applicative m) => WDSessionState m where

  -- |Retrieves the current session state of the monad
  getSession :: m WDSession

  -- |Sets a new session state for the monad
  putSession :: WDSession -> m ()

-- |Constraint synonym for the common pairing of 'WDSessionState' and 'MonadBase' 'IO'.
type WDSessionStateIO s = (WDSessionState s, MonadBase IO s)

-- |Constraint synonym for another common pairing of 'WDSessionState' and 'MonadBaseControl' 'IO'. This
-- is commonly used in library types to indicate use of lifted exception handling.
type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s)

modifySession :: WDSessionState s => (WDSession -> WDSession) -> s ()
modifySession :: forall (s :: * -> *).
WDSessionState s =>
(WDSession -> WDSession) -> s ()
modifySession WDSession -> WDSession
f = forall (m :: * -> *). WDSessionState m => m WDSession
getSession forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession forall b c a. (b -> c) -> (a -> b) -> a -> c
. WDSession -> WDSession
f

-- |Locally sets a session state for use within the given action.
-- The state of any outside action is unaffected by this function.
-- This function is useful if you need to work with multiple sessions simultaneously.
withSession :: WDSessionStateControl m => WDSession -> m a -> m a
withSession :: forall (m :: * -> *) a.
WDSessionStateControl m =>
WDSession -> m a -> m a
withSession WDSession
s m a
m = do
  WDSession
s' <- forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession WDSession
s
  (Either SomeException a
a :: Either SomeException a) <- forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try m a
m
  forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession WDSession
s'
  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 Either SomeException a
a

-- |The most recent SessionHistory entry recorded by this session, if any.
mostRecentHistory :: WDSession -> Maybe SessionHistory
mostRecentHistory :: WDSession -> Maybe SessionHistory
mostRecentHistory = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. WDSession -> [SessionHistory]
wdSessHist

-- |The most recent HTTP request issued by this session, if any.
mostRecentHTTPRequest :: WDSession -> Maybe Request
mostRecentHTTPRequest :: WDSession -> Maybe Request
mostRecentHTTPRequest = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SessionHistory -> Request
histRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. WDSession -> Maybe SessionHistory
mostRecentHistory

-- |Set a temporary list of custom 'RequestHeaders' to use within the given action.
-- All previous custom headers are temporarily removed, and then restored at the end.
withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a
withRequestHeaders :: forall (m :: * -> *) a.
WDSessionStateControl m =>
RequestHeaders -> m a -> m a
withRequestHeaders RequestHeaders
h m a
m = do
  RequestHeaders
h' <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WDSession -> RequestHeaders
wdSessRequestHeaders forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  forall (s :: * -> *).
WDSessionState s =>
(WDSession -> WDSession) -> s ()
modifySession forall a b. (a -> b) -> a -> b
$ \WDSession
s -> WDSession
s { wdSessRequestHeaders :: RequestHeaders
wdSessRequestHeaders = RequestHeaders
h }
  (Either SomeException a
a :: Either SomeException a) <- forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try m a
m
  forall (s :: * -> *).
WDSessionState s =>
(WDSession -> WDSession) -> s ()
modifySession forall a b. (a -> b) -> a -> b
$ \WDSession
s -> WDSession
s { wdSessRequestHeaders :: RequestHeaders
wdSessRequestHeaders = RequestHeaders
h' }
  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 Either SomeException a
a

-- |Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically
-- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use
-- the same auth headers you used for session creation with other HTTP requests.
withAuthHeaders :: WDSessionStateControl m => m a -> m a
withAuthHeaders :: forall (m :: * -> *) a. WDSessionStateControl m => m a -> m a
withAuthHeaders m a
wd = do
  RequestHeaders
authHeaders <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WDSession -> RequestHeaders
wdSessAuthHeaders forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  forall (m :: * -> *) a.
WDSessionStateControl m =>
RequestHeaders -> m a -> m a
withRequestHeaders RequestHeaders
authHeaders m a
wd

instance WDSessionState m => WDSessionState (LS.StateT s m) where
  getSession :: StateT s m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> StateT s m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (SS.StateT s m) where
  getSession :: StateT s m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> StateT s m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (MaybeT m) where
  getSession :: MaybeT m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> MaybeT m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (IdentityT m) where
  getSession :: IdentityT m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> IdentityT m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (ListT m) where
  getSession :: ListT m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> ListT m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where
  getSession :: WriterT w m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> WriterT w m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance (Monoid w, WDSessionState m) => WDSessionState (SW.WriterT w m) where
  getSession :: WriterT w m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> WriterT w m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (ReaderT r m) where
  getSession :: ReaderT r m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> ReaderT r m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance (Error e, WDSessionState m) => WDSessionState (ErrorT e m) where
  getSession :: ErrorT e m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> ErrorT e m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance WDSessionState m => WDSessionState (ExceptT r m) where
  getSession :: ExceptT r m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> ExceptT r m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance (Monoid w, WDSessionState m) => WDSessionState (SRWS.RWST r w s m) where
  getSession :: RWST r w s m WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> RWST r w s m ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession

instance (Monoid w, WDSessionState wd) => WDSessionState (LRWS.RWST r w s wd) where
  getSession :: RWST r w s wd WDSession
getSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  putSession :: WDSession -> RWST r w s wd ()
putSession = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession