{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, NamedFieldPuns #-}
module Test.WebDriver.Exceptions.Internal
( InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..)
, UnknownCommand(..), ServerError(..)
, FailedCommand(..), failedCommand, mkFailedCommandInfo
, FailedCommandType(..), FailedCommandInfo(..), StackFrame(..)
, externalCallStack, callStackItemToStackFrame
) where
import Test.WebDriver.Session
import Test.WebDriver.JSON
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.CallStack
import qualified Data.List as L
import Data.Text (Text)
import qualified Data.Text.Lazy.Encoding as TLE
import Control.Applicative
import Control.Exception (Exception)
import Control.Exception.Lifted (throwIO)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Typeable (Typeable)
import Prelude
instance Exception InvalidURL
newtype InvalidURL = InvalidURL String
deriving (Eq, Show, Typeable)
instance Exception HTTPStatusUnknown
data HTTPStatusUnknown = HTTPStatusUnknown Int String
deriving (Eq, Show, Typeable)
instance Exception HTTPConnError
data HTTPConnError = HTTPConnError String Int
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
deriving (Eq, Ord, Enum, Bounded, Show)
data FailedCommandInfo =
FailedCommandInfo {
errMsg :: String
, errSess :: Maybe 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 = case errSess i of
Nothing -> showString "None"
Just WDSession{..} ->
let sessId = maybe "<no session id>" show wdSessId
in showString sessId . showString " at "
. shows wdSessHost . showChar ':' . shows wdSessPort
mkFailedCommandInfo :: (WDSessionState s) => String -> CallStack -> s FailedCommandInfo
mkFailedCommandInfo m cs = do
sess <- getSession
return $ FailedCommandInfo { errMsg = m
, errSess = Just sess
, errScreen = Nothing
, errClass = Nothing
, errStack = fmap callStackItemToStackFrame cs }
externalCallStack :: (HasCallStack) => CallStack
externalCallStack = dropWhile isWebDriverFrame callStack
where isWebDriverFrame :: ([Char], SrcLoc) -> Bool
isWebDriverFrame (_, SrcLoc {srcLocModule}) = "Test.WebDriver" `L.isPrefixOf` srcLocModule
failedCommand :: (HasCallStack, WDSessionStateIO s) => FailedCommandType -> String -> s a
failedCommand t m = do
throwIO . FailedCommand t =<< mkFailedCommandInfo m externalCallStack
data StackFrame = StackFrame { sfFileName :: String
, sfClassName :: String
, sfMethodName :: String
, sfLineNumber :: Int
}
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 Nothing
<*> (fmap TLE.encodeUtf8 <$> opt "screen" Nothing)
<*> opt "class" Nothing
<*> (catMaybes <$> 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
callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame
callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { sfFileName = srcLocFile
, sfClassName = srcLocModule
, sfMethodName = functionName
, sfLineNumber = srcLocStartLine
}