module Test.WebDriver.Internal
( mkWDUri, mkRequest, sendHTTPRequest
, handleHTTPErr, handleJSONErr, handleHTTPResp
, WDResponse(..)
, InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..)
, UnknownCommand(..), ServerError(..)
, FailedCommand(..), failedCommand, mkFailedCommandInfo
, FailedCommandType(..), FailedCommandInfo(..), StackFrame(..)
) where
import Test.WebDriver.Classes
import Test.WebDriver.JSON
import Network.HTTP (simpleHTTP, Request(..), Response(..))
import Network.HTTP.Headers (findHeader, Header(..), HeaderName(..))
import Network.Stream (ConnError)
import Network.URI
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.Text as T (Text, unpack, splitOn, null)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.ByteString.Lazy.Char8 as LBS (length, unpack, null)
import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.Text.Lazy.Encoding as TL
import Control.Monad.Base
import Control.Exception.Lifted (throwIO)
import Control.Applicative
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Data.List (isInfixOf)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import Data.Word (Word, Word8)
mkWDUri :: (SessionState s) => String -> s URI
mkWDUri wdPath = do
WDSession{wdHost = host,
wdPort = port,
wdBasePath = basePath
} <- getSession
let urlStr = "http://" ++ host ++ ":" ++ show port
relPath = basePath ++ wdPath
mBaseURI = parseAbsoluteURI urlStr
mRelURI = parseRelativeReference relPath
case (mBaseURI, mRelURI) of
(Nothing, _) -> throwIO $ InvalidURL urlStr
(_, Nothing) -> throwIO $ InvalidURL relPath
(Just baseURI, Just relURI) -> return $ relURI `relativeTo` baseURI
mkRequest :: (SessionState s, ToJSON a) =>
[Header] -> RequestMethod -> Text -> a -> s (Request ByteString)
mkRequest headers method wdPath args = do
uri <- mkWDUri (T.unpack wdPath)
let body = case toJSON args of
Null -> ""
other -> encode other
return Request { rqURI = uri
, rqMethod = method
, rqBody = body
, rqHeaders = headers ++ [ Header HdrAccept
"application/json;charset=UTF-8"
, Header HdrContentType
"application/json;charset=UTF-8"
, Header HdrContentLength
. show . LBS.length $ body
]
}
sendHTTPRequest :: SessionState s => Request ByteString -> s (Response ByteString)
sendHTTPRequest req = do
r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return
modifySession $ \s -> s {lastHTTPRequest = Just req}
return r
handleHTTPErr :: SessionState s => Response ByteString -> s ()
handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} =
case code of
(4,_,_) -> do
lastReq <- lastHTTPRequest <$> getSession
throwIO . UnknownCommand . maybe reason show
$ lastReq
(5,_,_) ->
case findHeader HdrContentType r of
Just ct
| "application/json;" `isInfixOf` ct -> parseJSON' body
>>= handleJSONErr
| otherwise -> err ServerError
Nothing ->
err (ServerError . ("Missing content type. Server response: "++))
(2,_,_) -> return ()
(3,0,x) | x `elem` [2,3]
-> return ()
_ -> err (HTTPStatusUnknown code)
where
err errType = throwIO $ errType reason
handleHTTPResp :: (SessionState s, FromJSON a) => Response ByteString -> s a
handleHTTPResp resp@Response{rspBody = body, rspCode = code} =
case code of
(2,0,4) -> noReturn
(3,0,x)
| x `elem` [2,3] ->
case findHeader HdrLocation resp of
Nothing -> throwIO . HTTPStatusUnknown code
$ (LBS.unpack body)
Just loc -> do
let sessId = last . filter (not . T.null) . splitOn "/" . fromString $ loc
modifySession $ \sess -> sess {wdSessId = Just (SessionId sessId)}
fromJSON' . String $ sessId
_
| LBS.null body -> noReturn
| otherwise -> do
sess@WDSession { wdSessId = sessId} <- getSession
WDResponse { rspSessId = sessId'
, rspVal = val} <- parseJSON' body
case (sessId, (==) <$> sessId <*> sessId') of
(Nothing, _) -> putSession sess { wdSessId = sessId' }
(_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId'
++ ") does not match local session ID (" ++ show sessId ++ ")"
_ -> return ()
fromJSON' val
where
noReturn = fromJSON' Null
handleJSONErr :: SessionState s => WDResponse -> s ()
handleJSONErr WDResponse{rspStatus = 0} = return ()
handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do
sess <- getSession
errInfo <- fromJSON' val
let screen = B64.decodeLenient <$> errScreen errInfo
errInfo' = errInfo { errSess = sess
, errScreen = screen }
e errType = throwIO $ FailedCommand errType errInfo'
case status of
7 -> e NoSuchElement
8 -> e NoSuchFrame
9 -> throwIO . UnknownCommand . errMsg $ errInfo
10 -> e StaleElementReference
11 -> e ElementNotVisible
12 -> e InvalidElementState
13 -> e UnknownError
15 -> e ElementIsNotSelectable
17 -> e JavascriptError
19 -> e XPathLookupError
21 -> e Timeout
23 -> e NoSuchWindow
24 -> e InvalidCookieDomain
25 -> e UnableToSetCookie
26 -> e UnexpectedAlertOpen
27 -> e NoAlertOpen
28 -> e ScriptTimeout
29 -> e InvalidElementCoordinates
30 -> e IMENotAvailable
31 -> e IMEEngineActivationFailed
32 -> e InvalidSelector
33 -> e SessionNotCreated
34 -> e MoveTargetOutOfBounds
51 -> e InvalidXPathSelector
52 -> e InvalidXPathSelectorReturnType
405 -> e MethodNotAllowed
_ -> e UnknownError
data WDResponse = WDResponse { rspSessId :: Maybe SessionId
, rspStatus :: Word8
, rspVal :: Value
}
deriving (Eq, Show)
instance FromJSON WDResponse where
parseJSON (Object o) = WDResponse <$> o .:? "sessionId" .!= Nothing
<*> o .: "status"
<*> o .:? "value" .!= Null
parseJSON v = typeMismatch "WDResponse" v
instance Exception InvalidURL
newtype InvalidURL = InvalidURL String
deriving (Eq, Show, Typeable)
instance Exception HTTPStatusUnknown
data HTTPStatusUnknown = HTTPStatusUnknown (Int, Int, Int) String
deriving (Eq, Show, Typeable)
instance Exception HTTPConnError
newtype HTTPConnError = HTTPConnError ConnError
deriving (Eq, Show, Typeable)
instance Exception UnknownCommand
newtype UnknownCommand = UnknownCommand String
deriving (Eq, Show, Typeable)
instance Exception ServerError
newtype ServerError = ServerError String
deriving (Eq, Show, Typeable)
instance Exception FailedCommand
data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo
deriving (Show, Typeable)
data FailedCommandType = NoSuchElement
| NoSuchFrame
| UnknownFrame
| StaleElementReference
| ElementNotVisible
| InvalidElementState
| UnknownError
| ElementIsNotSelectable
| JavascriptError
| XPathLookupError
| Timeout
| NoSuchWindow
| InvalidCookieDomain
| UnableToSetCookie
| UnexpectedAlertOpen
| NoAlertOpen
| ScriptTimeout
| InvalidElementCoordinates
| IMENotAvailable
| IMEEngineActivationFailed
| InvalidSelector
| SessionNotCreated
| MoveTargetOutOfBounds
| InvalidXPathSelector
| InvalidXPathSelectorReturnType
| MethodNotAllowed
deriving (Eq, Ord, Enum, Bounded, Show)
data FailedCommandInfo =
FailedCommandInfo {
errMsg :: String
, errSess :: WDSession
, errScreen :: Maybe ByteString
, errClass :: Maybe String
, errStack :: [StackFrame]
}
instance Show FailedCommandInfo where
show i = showChar '\n'
. showString "Session: " . sess
. showChar '\n'
. showString className . showString ": " . showString (errMsg i)
. showChar '\n'
. foldl (\f s-> f . showString " " . shows s) id (errStack i)
$ ""
where
className = fromMaybe "<unknown exception>" . errClass $ i
sess = showString sessId . showString " at "
. showString host . showChar ':' . shows port
where
sessId = case msid of
Just (SessionId sid) -> T.unpack sid
Nothing -> "<no session id>"
WDSession {wdHost = host, wdPort = port, wdSessId = msid } = errSess i
mkFailedCommandInfo :: SessionState s => String -> s FailedCommandInfo
mkFailedCommandInfo m = do
sess <- getSession
return $ FailedCommandInfo {errMsg = m , errSess = sess , errScreen = Nothing
, errClass = Nothing , errStack = [] }
failedCommand :: SessionState s => FailedCommandType -> String -> s a
failedCommand t m = throwIO . FailedCommand t =<< mkFailedCommandInfo m
data StackFrame = StackFrame { sfFileName :: String
, sfClassName :: String
, sfMethodName :: String
, sfLineNumber :: Word
}
deriving (Eq)
instance Show StackFrame where
show f = showString (sfClassName f) . showChar '.'
. showString (sfMethodName f) . showChar ' '
. showParen True ( showString (sfFileName f) . showChar ':'
. shows (sfLineNumber f))
$ "\n"
instance FromJSON FailedCommandInfo where
parseJSON (Object o) =
FailedCommandInfo <$> (req "message" >>= maybe (return "") return)
<*> pure undefined
<*> (fmap TL.encodeUtf8 <$> opt "screen" Nothing)
<*> opt "class" Nothing
<*> opt "stackTrace" []
where req :: FromJSON a => Text -> Parser a
req = (o .:)
opt :: FromJSON a => Text -> a -> Parser a
opt k d = o .:? k .!= d
parseJSON v = typeMismatch "FailedCommandInfo" v
instance FromJSON StackFrame where
parseJSON (Object o) = StackFrame <$> reqStr "fileName"
<*> reqStr "className"
<*> reqStr "methodName"
<*> req "lineNumber"
where req :: FromJSON a => Text -> Parser a
req = (o .:)
reqStr :: Text -> Parser String
reqStr k = req k >>= maybe (return "") return
parseJSON v = typeMismatch "StackFrame" v