{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE CPP #-}

-- | The HTTP/JSON plumbing used to implement the 'WD' monad.
--
-- These functions can be used to create your own 'WebDriver' instances, providing extra functionality for your application if desired. All exports
-- of this module are subject to change at any point.
module Test.WebDriver.Internal
       ( mkRequest, sendHTTPRequest
       , getJSONResult, handleJSONErr, handleRespSessionId
       , WDResponse(..)
       ) where
import Test.WebDriver.Class
import Test.WebDriver.JSON
import Test.WebDriver.Session
import Test.WebDriver.Exceptions.Internal

import Network.HTTP.Client (httpLbs, Request(..), RequestBody(..), Response(..))
import qualified Network.HTTP.Client as HTTPClient

import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status (Status(..))

import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.ByteString.Lazy.Char8 as LBS (unpack, null)
import qualified Data.ByteString.Lazy.Internal as LBS (ByteString(..))
import Data.CallStack
import Data.Text as T (Text, splitOn, null)
import qualified Data.Text.Encoding as TE

import Control.Applicative
import Control.Exception (Exception, SomeException(..), toException, fromException, try)
import Control.Exception.Lifted (throwIO)
import Control.Monad.Base

import Data.String (fromString)
import Data.Word (Word8)

#if !MIN_VERSION_http_client(0,4,30)
import Data.Default (def)
#endif

import Prelude -- hides some "unused import" warnings

--This is the defintion of fromStrict used by bytestring >= 0.10; we redefine it here to support bytestring < 0.10
fromStrict :: BS.ByteString -> LBS.ByteString
fromStrict :: ByteString -> ByteString
fromStrict ByteString
bs | ByteString -> Bool
BS.null ByteString
bs = ByteString
LBS.Empty
              | Bool
otherwise = ByteString -> ByteString -> ByteString
LBS.Chunk ByteString
bs ByteString
LBS.Empty


--Compatability function to support http-client < 0.4.30
defaultRequest :: Request
#if MIN_VERSION_http_client(0,4,30)
defaultRequest :: Request
defaultRequest = Request
HTTPClient.defaultRequest
#else
defaultRequest = def
#endif

-- |Constructs an HTTP 'Request' value when given a list of headers, HTTP request method, and URL fragment
mkRequest :: (WDSessionState s, ToJSON a) =>
             Method -> Text -> a -> s Request
mkRequest :: forall (s :: * -> *) a.
(WDSessionState s, ToJSON a) =>
ByteString -> Text -> a -> s Request
mkRequest ByteString
meth Text
wdPath a
args = do
  WDSession {Int
RequestHeaders
[SessionHistory]
Maybe SessionId
ByteString
Manager
SessionHistoryConfig
wdSessHost :: ByteString
wdSessPort :: Int
wdSessBasePath :: ByteString
wdSessId :: Maybe SessionId
wdSessHist :: [SessionHistory]
wdSessHistUpdate :: SessionHistoryConfig
wdSessHTTPManager :: Manager
wdSessHTTPRetryCount :: Int
wdSessRequestHeaders :: RequestHeaders
wdSessAuthHeaders :: RequestHeaders
wdSessHost :: WDSession -> ByteString
wdSessPort :: WDSession -> Int
wdSessBasePath :: WDSession -> ByteString
wdSessId :: WDSession -> Maybe SessionId
wdSessHist :: WDSession -> [SessionHistory]
wdSessHistUpdate :: WDSession -> SessionHistoryConfig
wdSessHTTPManager :: WDSession -> Manager
wdSessHTTPRetryCount :: WDSession -> Int
wdSessRequestHeaders :: WDSession -> RequestHeaders
wdSessAuthHeaders :: WDSession -> RequestHeaders
..} <- s WDSession
forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  let body :: ByteString
body = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
args of
        Value
Null  -> ByteString
""   --passing Null as the argument indicates no request body
        Value
other -> Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
other
  Request -> s Request
forall a. a -> s a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
defaultRequest
    { host = wdSessHost
    , port = wdSessPort
    , path = wdSessBasePath `BS.append`  TE.encodeUtf8 wdPath
    , requestBody = RequestBodyLBS body
    , requestHeaders = wdSessRequestHeaders
                       ++ [ (hAccept, "application/json;charset=UTF-8")
                          , (hContentType, "application/json;charset=UTF-8") ]
    , method = meth
#if !MIN_VERSION_http_client(0,5,0)
    , checkStatus = \_ _ _ -> Nothing
#endif
    }

-- |Sends an HTTP request to the remote WebDriver server
sendHTTPRequest :: (WDSessionStateIO s) => Request -> s (Either SomeException (Response ByteString))
sendHTTPRequest :: forall (s :: * -> *).
WDSessionStateIO s =>
Request -> s (Either SomeException (Response ByteString))
sendHTTPRequest Request
req = do
  s :: WDSession
s@WDSession{Int
RequestHeaders
[SessionHistory]
Maybe SessionId
ByteString
Manager
SessionHistoryConfig
wdSessHost :: WDSession -> ByteString
wdSessPort :: WDSession -> Int
wdSessBasePath :: WDSession -> ByteString
wdSessId :: WDSession -> Maybe SessionId
wdSessHist :: WDSession -> [SessionHistory]
wdSessHistUpdate :: WDSession -> SessionHistoryConfig
wdSessHTTPManager :: WDSession -> Manager
wdSessHTTPRetryCount :: WDSession -> Int
wdSessRequestHeaders :: WDSession -> RequestHeaders
wdSessAuthHeaders :: WDSession -> RequestHeaders
wdSessHost :: ByteString
wdSessPort :: Int
wdSessBasePath :: ByteString
wdSessId :: Maybe SessionId
wdSessHist :: [SessionHistory]
wdSessHistUpdate :: SessionHistoryConfig
wdSessHTTPManager :: Manager
wdSessHTTPRetryCount :: Int
wdSessRequestHeaders :: RequestHeaders
wdSessAuthHeaders :: RequestHeaders
..} <- s WDSession
forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  (Int
nRetries, Either SomeException (Response ByteString)
tryRes) <- IO (Int, Either SomeException (Response ByteString))
-> s (Int, Either SomeException (Response ByteString))
forall α. IO α -> s α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Int, Either SomeException (Response ByteString))
 -> s (Int, Either SomeException (Response ByteString)))
-> (IO (Response ByteString)
    -> IO (Int, Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> s (Int, Either SomeException (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> IO (Response ByteString)
-> IO (Int, Either SomeException (Response ByteString))
forall a. Int -> IO a -> IO (Int, Either SomeException a)
retryOnTimeout Int
wdSessHTTPRetryCount (IO (Response ByteString)
 -> s (Int, Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> s (Int, Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
wdSessHTTPManager
  let h :: SessionHistory
h = SessionHistory { histRequest :: Request
histRequest = Request
req
                         , histResponse :: Either SomeException (Response ByteString)
histResponse = Either SomeException (Response ByteString)
tryRes
                         , histRetryCount :: Int
histRetryCount = Int
nRetries
                         }
  WDSession -> s ()
forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession WDSession
s { wdSessHist = wdSessHistUpdate h wdSessHist }
  Either SomeException (Response ByteString)
-> s (Either SomeException (Response ByteString))
forall a. a -> s a
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException (Response ByteString)
tryRes

retryOnTimeout :: Int -> IO a -> IO (Int, (Either SomeException a))
retryOnTimeout :: forall a. Int -> IO a -> IO (Int, Either SomeException a)
retryOnTimeout Int
maxRetry IO a
go = Int -> IO (Int, Either SomeException a)
retry' Int
0
  where
    retry' :: Int -> IO (Int, Either SomeException a)
retry' Int
nRetries = do
      Either SomeException a
eitherV <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
go
      case Either SomeException a
eitherV of
        (Left SomeException
e)
#if MIN_VERSION_http_client(0,5,0)
          | Just (HTTPClient.HttpExceptionRequest Request
_ HttpExceptionContent
HTTPClient.ResponseTimeout) <- SomeException -> Maybe HttpException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
#else
          | Just HTTPClient.ResponseTimeout <- fromException e
#endif
          , Int
maxRetry Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
nRetries
          -> Int -> IO (Int, Either SomeException a)
retry' (Int -> Int
forall a. Enum a => a -> a
succ Int
nRetries)
        Either SomeException a
other -> (Int, Either SomeException a) -> IO (Int, Either SomeException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nRetries, Either SomeException a
other)

-- |Parses a 'WDResponse' object from a given HTTP response.
getJSONResult :: (HasCallStack, WDSessionStateControl s, FromJSON a) => Response ByteString -> s (Either SomeException a)
getJSONResult :: forall (s :: * -> *) a.
(HasCallStack, WDSessionStateControl s, FromJSON a) =>
Response ByteString -> s (Either SomeException a)
getJSONResult Response ByteString
r
  --malformed request errors
  | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
500 = do
    Maybe Request
lastReq <- WDSession -> Maybe Request
mostRecentHTTPRequest (WDSession -> Maybe Request) -> s WDSession -> s (Maybe Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s WDSession
forall (m :: * -> *). WDSessionState m => m WDSession
getSession
    UnknownCommand -> s (Either SomeException a)
forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr (UnknownCommand -> s (Either SomeException a))
-> (Maybe Request -> UnknownCommand)
-> Maybe Request
-> s (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnknownCommand
UnknownCommand (String -> UnknownCommand)
-> (Maybe Request -> String) -> Maybe Request -> UnknownCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Request -> String) -> Maybe Request -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
reason Request -> String
forall a. Show a => a -> String
show (Maybe Request -> s (Either SomeException a))
-> Maybe Request -> s (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ Maybe Request
lastReq
  --server-side errors
  | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
600 =
    case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType RequestHeaders
headers of
      Just ByteString
ct
        | ByteString
"application/json" ByteString -> ByteString -> Bool
`BS.isInfixOf` ByteString
ct ->
          ByteString -> s WDResponse
forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
ByteString -> wd a
parseJSON'
            (ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
body ByteString -> ByteString
fromStrict (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Response-Body-Start" RequestHeaders
headers)
          s WDResponse
-> (WDResponse -> s (Maybe SomeException))
-> s (Maybe SomeException)
forall a b. s a -> (a -> s b) -> s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WDResponse -> s (Maybe SomeException)
forall (s :: * -> *).
(HasCallStack, WDSessionStateControl s) =>
WDResponse -> s (Maybe SomeException)
handleJSONErr
          s (Maybe SomeException)
-> (Maybe SomeException -> s (Either SomeException a))
-> s (Either SomeException a)
forall a b. s a -> (a -> s b) -> s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s (Either SomeException a)
-> (SomeException -> s (Either SomeException a))
-> Maybe SomeException
-> s (Either SomeException a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe s (Either SomeException a)
forall {a}. s (Either a a)
returnNull SomeException -> s (Either SomeException a)
forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr
        | Bool
otherwise ->
          (String -> ServerError) -> s (Either SomeException a)
forall {b} {m :: * -> *} {a}.
(Exception b, Monad m) =>
(String -> b) -> m (Either SomeException a)
returnHTTPErr String -> ServerError
ServerError
      Maybe ByteString
Nothing ->
        (String -> ServerError) -> s (Either SomeException a)
forall {b} {m :: * -> *} {a}.
(Exception b, Monad m) =>
(String -> b) -> m (Either SomeException a)
returnHTTPErr (String -> ServerError
ServerError (String -> ServerError)
-> (String -> String) -> String -> ServerError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"HTTP response missing content type. Server reason was: "String -> String -> String
forall a. [a] -> [a] -> [a]
++))
  --redirect case (used as a response to createSession requests)
  | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
302 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
303 =
    case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLocation RequestHeaders
headers of
      Maybe ByteString
Nothing ->  HTTPStatusUnknown -> s (Either SomeException a)
forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr (HTTPStatusUnknown -> s (Either SomeException a))
-> (String -> HTTPStatusUnknown)
-> String
-> s (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> HTTPStatusUnknown
HTTPStatusUnknown Int
code (String -> s (Either SomeException a))
-> String -> s (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ ByteString -> String
LBS.unpack ByteString
body
      Just ByteString
loc -> do
        let sessId :: Text
sessId = [Text] -> Text
forall a. HasCallStack => [a] -> a
last ([Text] -> Text) -> (String -> [Text]) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"/" (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
loc
        (WDSession -> WDSession) -> s ()
forall (s :: * -> *).
WDSessionState s =>
(WDSession -> WDSession) -> s ()
modifySession ((WDSession -> WDSession) -> s ())
-> (WDSession -> WDSession) -> s ()
forall a b. (a -> b) -> a -> b
$ \WDSession
sess -> WDSession
sess {wdSessId = Just (SessionId sessId)}
        s (Either SomeException a)
forall {a}. s (Either a a)
returnNull
  -- No Content response
  | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
204 = s (Either SomeException a)
forall {a}. s (Either a a)
returnNull
  -- HTTP Success
  | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 =
    if ByteString -> Bool
LBS.null ByteString
body
      then s (Either SomeException a)
forall {a}. s (Either a a)
returnNull
      else do
        rsp :: WDResponse
rsp@WDResponse {rspVal :: WDResponse -> Value
rspVal = Value
val} <- ByteString -> s WDResponse
forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
ByteString -> wd a
parseJSON' ByteString
body
        WDResponse -> s (Maybe SomeException)
forall (s :: * -> *).
(HasCallStack, WDSessionStateControl s) =>
WDResponse -> s (Maybe SomeException)
handleJSONErr WDResponse
rsp s (Maybe SomeException)
-> (Maybe SomeException -> s (Either SomeException a))
-> s (Either SomeException a)
forall a b. s a -> (a -> s b) -> s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s (Either SomeException a)
-> (SomeException -> s (Either SomeException a))
-> Maybe SomeException
-> s (Either SomeException a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (WDResponse -> s ()
forall (s :: * -> *).
(HasCallStack, WDSessionStateIO s) =>
WDResponse -> s ()
handleRespSessionId WDResponse
rsp s () -> s (Either SomeException a) -> s (Either SomeException a)
forall a b. s a -> s b -> s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Either SomeException a
forall a b. b -> Either a b
Right (a -> Either SomeException a) -> s a -> s (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> s a
forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Value -> wd a
fromJSON' Value
val)
          SomeException -> s (Either SomeException a)
forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr
  -- other status codes: return error
  | Bool
otherwise = (String -> HTTPStatusUnknown) -> s (Either SomeException a)
forall {b} {m :: * -> *} {a}.
(Exception b, Monad m) =>
(String -> b) -> m (Either SomeException a)
returnHTTPErr (Int -> String -> HTTPStatusUnknown
HTTPStatusUnknown Int
code)
  where
    --helper functions
    returnErr :: (Exception e, Monad m) => e -> m (Either SomeException a)
    returnErr :: forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr = Either SomeException a -> m (Either SomeException a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> m (Either SomeException a))
-> (e -> Either SomeException a) -> e -> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left (SomeException -> Either SomeException a)
-> (e -> SomeException) -> e -> Either SomeException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
toException
    returnHTTPErr :: (String -> b) -> m (Either SomeException a)
returnHTTPErr String -> b
errType = b -> m (Either SomeException a)
forall e (m :: * -> *) a.
(Exception e, Monad m) =>
e -> m (Either SomeException a)
returnErr (b -> m (Either SomeException a))
-> (String -> b) -> String -> m (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> b
errType (String -> m (Either SomeException a))
-> String -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ String
reason
    returnNull :: s (Either a a)
returnNull = a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> s a -> s (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> s a
forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Value -> wd a
fromJSON' Value
Null
    --HTTP response variables
    code :: Int
code = Status -> Int
statusCode Status
status
    reason :: String
reason = ByteString -> String
BS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Status -> ByteString
statusMessage Status
status
    status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
r
    body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
r
    headers :: RequestHeaders
headers = Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response ByteString
r

handleRespSessionId :: (HasCallStack, WDSessionStateIO s) => WDResponse -> s ()
handleRespSessionId :: forall (s :: * -> *).
(HasCallStack, WDSessionStateIO s) =>
WDResponse -> s ()
handleRespSessionId WDResponse{rspSessId :: WDResponse -> Maybe SessionId
rspSessId = Maybe SessionId
sessId'} = do
    sess :: WDSession
sess@WDSession { wdSessId :: WDSession -> Maybe SessionId
wdSessId = Maybe SessionId
sessId} <- s WDSession
forall (m :: * -> *). WDSessionState m => m WDSession
getSession
    case (Maybe SessionId
sessId, SessionId -> SessionId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (SessionId -> SessionId -> Bool)
-> Maybe SessionId -> Maybe (SessionId -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SessionId
sessId Maybe (SessionId -> Bool) -> Maybe SessionId -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe SessionId
sessId') of
       -- if our monad has an uninitialized session ID, initialize it from the response object
       (Maybe SessionId
Nothing, Maybe Bool
_)    -> WDSession -> s ()
forall (m :: * -> *). WDSessionState m => WDSession -> m ()
putSession WDSession
sess { wdSessId = sessId' }
       -- if the response ID doesn't match our local ID, throw an error.
       (Maybe SessionId
_, Just Bool
False) -> ServerError -> s ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (ServerError -> s ()) -> (String -> ServerError) -> String -> s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerError
ServerError (String -> s ()) -> String -> s ()
forall a b. (a -> b) -> a -> b
$ String
"Server response session ID (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe SessionId -> String
forall a. Show a => a -> String
show Maybe SessionId
sessId'
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") does not match local session ID (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe SessionId -> String
forall a. Show a => a -> String
show Maybe SessionId
sessId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
       (Maybe SessionId, Maybe Bool)
_ ->  () -> s ()
forall a. a -> s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleJSONErr :: (HasCallStack, WDSessionStateControl s) => WDResponse -> s (Maybe SomeException)
handleJSONErr :: forall (s :: * -> *).
(HasCallStack, WDSessionStateControl s) =>
WDResponse -> s (Maybe SomeException)
handleJSONErr WDResponse{rspStatus :: WDResponse -> Word8
rspStatus = Word8
0} = Maybe SomeException -> s (Maybe SomeException)
forall a. a -> s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
handleJSONErr WDResponse{rspVal :: WDResponse -> Value
rspVal = Value
val, rspStatus :: WDResponse -> Word8
rspStatus = Word8
status} = do
  WDSession
sess <- s WDSession
forall (m :: * -> *). WDSessionState m => m WDSession
getSession
  FailedCommandInfo
errInfo <- Value -> s FailedCommandInfo
forall (wd :: * -> *) a.
(MonadBaseControl IO wd, FromJSON a) =>
Value -> wd a
fromJSON' Value
val
  let screen :: Maybe ByteString
screen = ByteString -> ByteString
B64.decodeLenient (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FailedCommandInfo -> Maybe ByteString
errScreen FailedCommandInfo
errInfo
      seleniumStack :: [StackFrame]
seleniumStack = FailedCommandInfo -> [StackFrame]
errStack FailedCommandInfo
errInfo
      errInfo' :: FailedCommandInfo
errInfo' = FailedCommandInfo
errInfo { errSess = Just sess
                         -- Append the Haskell stack frames to the ones returned from Selenium
                         , errScreen = screen
                         , errStack = seleniumStack ++ (fmap callStackItemToStackFrame externalCallStack) }
      e :: FailedCommandType -> SomeException
e FailedCommandType
errType = FailedCommand -> SomeException
forall e. Exception e => e -> SomeException
toException (FailedCommand -> SomeException) -> FailedCommand -> SomeException
forall a b. (a -> b) -> a -> b
$ FailedCommandType -> FailedCommandInfo -> FailedCommand
FailedCommand FailedCommandType
errType FailedCommandInfo
errInfo'
  Maybe SomeException -> s (Maybe SomeException)
forall a. a -> s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SomeException -> s (Maybe SomeException))
-> (SomeException -> Maybe SomeException)
-> SomeException
-> s (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> s (Maybe SomeException))
-> SomeException -> s (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ case Word8
status of
    Word8
7   -> FailedCommandType -> SomeException
e FailedCommandType
NoSuchElement
    Word8
8   -> FailedCommandType -> SomeException
e FailedCommandType
NoSuchFrame
    Word8
9   -> UnknownCommand -> SomeException
forall e. Exception e => e -> SomeException
toException (UnknownCommand -> SomeException)
-> (FailedCommandInfo -> UnknownCommand)
-> FailedCommandInfo
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnknownCommand
UnknownCommand (String -> UnknownCommand)
-> (FailedCommandInfo -> String)
-> FailedCommandInfo
-> UnknownCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailedCommandInfo -> String
errMsg (FailedCommandInfo -> SomeException)
-> FailedCommandInfo -> SomeException
forall a b. (a -> b) -> a -> b
$ FailedCommandInfo
errInfo
    Word8
10  -> FailedCommandType -> SomeException
e FailedCommandType
StaleElementReference
    Word8
11  -> FailedCommandType -> SomeException
e FailedCommandType
ElementNotVisible
    Word8
12  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidElementState
    Word8
13  -> FailedCommandType -> SomeException
e FailedCommandType
UnknownError
    Word8
15  -> FailedCommandType -> SomeException
e FailedCommandType
ElementIsNotSelectable
    Word8
17  -> FailedCommandType -> SomeException
e FailedCommandType
JavascriptError
    Word8
19  -> FailedCommandType -> SomeException
e FailedCommandType
XPathLookupError
    Word8
21  -> FailedCommandType -> SomeException
e FailedCommandType
Timeout
    Word8
23  -> FailedCommandType -> SomeException
e FailedCommandType
NoSuchWindow
    Word8
24  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidCookieDomain
    Word8
25  -> FailedCommandType -> SomeException
e FailedCommandType
UnableToSetCookie
    Word8
26  -> FailedCommandType -> SomeException
e FailedCommandType
UnexpectedAlertOpen
    Word8
27  -> FailedCommandType -> SomeException
e FailedCommandType
NoAlertOpen
    Word8
28  -> FailedCommandType -> SomeException
e FailedCommandType
ScriptTimeout
    Word8
29  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidElementCoordinates
    Word8
30  -> FailedCommandType -> SomeException
e FailedCommandType
IMENotAvailable
    Word8
31  -> FailedCommandType -> SomeException
e FailedCommandType
IMEEngineActivationFailed
    Word8
32  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidSelector
    Word8
33  -> FailedCommandType -> SomeException
e FailedCommandType
SessionNotCreated
    Word8
34  -> FailedCommandType -> SomeException
e FailedCommandType
MoveTargetOutOfBounds
    Word8
51  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidXPathSelector
    Word8
52  -> FailedCommandType -> SomeException
e FailedCommandType
InvalidXPathSelectorReturnType
    Word8
_   -> FailedCommandType -> SomeException
e FailedCommandType
UnknownError


-- |Internal type representing the JSON response object
data WDResponse = WDResponse {
                               WDResponse -> Maybe SessionId
rspSessId :: Maybe SessionId
                             , WDResponse -> Word8
rspStatus :: Word8
                             , WDResponse -> Value
rspVal    :: Value
                             }
                  deriving (WDResponse -> WDResponse -> Bool
(WDResponse -> WDResponse -> Bool)
-> (WDResponse -> WDResponse -> Bool) -> Eq WDResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WDResponse -> WDResponse -> Bool
== :: WDResponse -> WDResponse -> Bool
$c/= :: WDResponse -> WDResponse -> Bool
/= :: WDResponse -> WDResponse -> Bool
Eq, Int -> WDResponse -> String -> String
[WDResponse] -> String -> String
WDResponse -> String
(Int -> WDResponse -> String -> String)
-> (WDResponse -> String)
-> ([WDResponse] -> String -> String)
-> Show WDResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WDResponse -> String -> String
showsPrec :: Int -> WDResponse -> String -> String
$cshow :: WDResponse -> String
show :: WDResponse -> String
$cshowList :: [WDResponse] -> String -> String
showList :: [WDResponse] -> String -> String
Show)

instance FromJSON WDResponse where
  parseJSON :: Value -> Parser WDResponse
parseJSON (Object Object
o) = Maybe SessionId -> Word8 -> Value -> WDResponse
WDResponse (Maybe SessionId -> Word8 -> Value -> WDResponse)
-> Parser (Maybe SessionId)
-> Parser (Word8 -> Value -> WDResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe (Maybe SessionId))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:?? Text
"sessionId" Parser (Maybe (Maybe SessionId))
-> Maybe SessionId -> Parser (Maybe SessionId)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Maybe SessionId
forall a. Maybe a
Nothing
                                    Parser (Word8 -> Value -> WDResponse)
-> Parser Word8 -> Parser (Value -> WDResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Word8
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status"
                                    Parser (Value -> WDResponse) -> Parser Value -> Parser WDResponse
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:?? Text
"value" Parser (Maybe Value) -> Value -> Parser Value
forall a. Parser (Maybe a) -> a -> Parser a
.!= Value
Null
  parseJSON Value
v = String -> Value -> Parser WDResponse
forall a. String -> Value -> Parser a
typeMismatch String
"WDResponse" Value
v