module Happybara.WebKit.Commands where
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BS (fromStrict, toStrict)
import qualified Data.CaseInsensitive as CI
import Data.Char (isDigit)
import Data.List (isPrefixOf)
import Data.Maybe (fromJust, maybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import qualified Data.Vector as V
import Control.Applicative
import Control.Exception
import Control.Monad
import System.IO
import System.Process
import System.Timeout
import Network.BSD
import Network.HTTP.Types
import Network.Socket
import System.Info (os)
import Happybara.Driver (FrameSelector (..),
NodeValue (..))
import Happybara.Exceptions
import Happybara.WebKit.Exceptions
import Happybara.WebKit.Session (Session (..))
type NodeHandle = Text
data JsonError = JsonError { jsonErrorClass :: String
, jsonErrorMessage :: String
}
instance FromJSON JsonError where
parseJSON (Object v) = JsonError <$>
v .: "class" <*>
v .: "message"
parseJSON _ = mzero
enc :: Text -> ByteString
enc s = encodeUtf8 s
dec :: IO ByteString -> IO Text
dec s = s >>= (return . decodeUtf8)
toValue :: ByteString -> Value
toValue str = case eitherDecode (BS.fromStrict str) of
Left msg -> error msg
Right val -> val
jsonErrorToException :: JsonError -> SomeException
jsonErrorToException (JsonError "NodeNotAttachedError" msg) =
toException $ NodeNotAttachedException msg
jsonErrorToException (JsonError "InvalidResponseError" msg) =
toException $ InvalidResponseException msg
jsonErrorToException (JsonError "NoResponseError" msg) =
toException $ NoResponseException msg
jsonErrorToException (JsonError "ClickFailed" msg) =
toException $ ClickFailedException msg
jsonErrorToException (JsonError "TimeoutError" msg) =
toException $ TimeoutException msg
jsonErrorToException (JsonError klass msg) =
error $ concat [ "Unkown exception type: ", klass ]
command :: Session -> ByteString -> [ByteString] -> IO ByteString
command sess cmd args = do
BS.hPutStrLn h cmd
BS.hPutStrLn h (BS.pack . show . length $ args)
forM_ args $ \arg -> do
BS.hPutStrLn h (BS.pack . show . BS.length $ arg)
BS.hPutStr h arg
hFlush h
check
readResponse
where
h = sockHandle sess
check = do
result <- BS.hGetLine h
when (result /= "ok") $ do
response <- readResponse
(throw . jsonErrorToException . fromJust . decode) $ BS.fromStrict response
readResponse = do
len <- (read . BS.unpack) <$> BS.hGetLine h
if len > 0
then BS.hGet h len
else return ""
invoke :: Session -> NodeHandle -> ByteString -> [ByteString] -> IO ByteString
invoke sess h name args =
command sess "Node" (name:allow_unattached_nodes:enc h:args)
where
allow_unattached_nodes = "true"
authenticate :: Session -> Text -> Text -> IO ()
authenticate sess username password =
void $ command sess "Authenticate" [enc username, enc password]
enableLogging :: Session -> IO ()
enableLogging sess =
void $ command sess "EnableLogging" []
visit :: Session -> Text -> IO ()
visit sess url =
void $ command sess "Visit" [enc url]
header :: Session -> Text -> Text -> IO ()
header sess key value =
void $ command sess "Header" [enc key, enc value]
getTitle :: Session -> IO Text
getTitle sess =
dec $ command sess "Title" []
findXPath :: Session -> Text -> IO [NodeHandle]
findXPath sess query =
T.splitOn "," <$> (dec $ command sess "FindXpath" [enc query])
findCSS :: Session -> Text -> IO [NodeHandle]
findCSS sess query =
T.splitOn "," <$> (dec $ command sess "FindCss" [enc query])
reset :: Session -> IO ()
reset sess =
void $ command sess "Reset" []
body :: Session -> IO Text
body sess =
dec $ command sess "Body" []
statusCode :: Session -> IO Int
statusCode sess =
(return . read . BS.unpack) =<< command sess "Status" []
consoleMessages :: Session -> IO Value
consoleMessages sess =
(return . toValue) =<< command sess "ConsoleMessages" []
alertMessages :: Session -> IO Value
alertMessages sess =
(return . toValue) =<< command sess "JavascriptAlertMessages" []
confirmMessages :: Session -> IO Value
confirmMessages sess =
(return . toValue) =<< command sess "JavascriptConfirmMessages" []
promptMessages :: Session -> IO Value
promptMessages sess =
(return . toValue) =<< command sess "JavascriptPromptMessages" []
responseHeaders :: Session -> IO ResponseHeaders
responseHeaders sess = do
str <- command sess "Headers" []
return $ map parseHeader (BS.lines str)
where
parseHeader :: ByteString -> Header
parseHeader s = let Just i = BS.elemIndex ':' s
k = BS.take i s
v = BS.drop (i+1) s
in (CI.mk k, v)
currentUrl :: Session -> IO Text
currentUrl sess =
dec $ command sess "CurrentUrl" []
setFrameFocus :: Session -> FrameSelector -> IO ()
setFrameFocus sess frame =
case frame of
FrameIndex idx ->
void $ command sess "FrameFocus" [enc "", BS.pack . show $ idx]
FrameName name ->
void $ command sess "FrameFocus" [enc name]
DefaultFrame ->
void $ command sess "FrameFocus" []
ignoreSslErrors :: Session -> IO ()
ignoreSslErrors sess =
void $ command sess "IgnoreSslErrors" []
setSkipImageLoading :: Session -> Bool -> IO ()
setSkipImageLoading sess flag =
void $ command sess "SetSkipImageLoading" [arg]
where
arg = if flag then "true" else "false"
acceptJsConfirms :: Session -> IO ()
acceptJsConfirms sess =
void $ command sess "SetConfirmAction" ["Yes"]
rejectJsConfirms :: Session -> IO ()
rejectJsConfirms sess =
void $ command sess "SetConfirmAction" ["No"]
acceptJsPrompts :: Session -> IO ()
acceptJsPrompts sess =
void $ command sess "SetPromptAction" ["Yes"]
rejectJsPrompts :: Session -> IO ()
rejectJsPrompts sess =
void $ command sess "SetPromptAction" ["No"]
setPromptTextTo :: Session -> Text -> IO ()
setPromptTextTo sess str =
void $ command sess "SetPromptText" [enc str]
clearPromptText :: Session -> IO ()
clearPromptText sess =
void $ command sess "ClearPromptText" []
setUrlBlacklist :: Session -> [Text] -> IO ()
setUrlBlacklist sess urls =
void $ command sess "SetUrlBlacklist" (map enc urls)
evaluateScript :: Session -> Text -> IO Value
evaluateScript sess script = do
res <- command sess "Evaluate" [enc script]
let Array array = toValue $ BS.concat ["[", res, "]"]
return $ V.head array
executeScript :: Session -> Text -> IO ()
executeScript sess script =
void $ command sess "Execute" [enc script]
render :: Session -> Text -> Int -> Int -> IO ()
render sess path width height =
void $ command sess "Render" [enc path, show' width, show' height]
where
show' = (BS.pack . show)
setTimeout :: Session -> Int -> IO ()
setTimeout sess seconds =
void $ command sess "SetTimeout" [BS.pack . show $ seconds]
getTimeout :: Session -> IO Int
getTimeout sess =
(return . read . BS.unpack) =<< command sess "GetTimeout" []
clearCookies :: Session -> IO ()
clearCookies sess =
void $ command sess "ClearCookies" []
clearProxy :: Session -> IO ()
clearProxy sess =
void $ command sess "SetProxy" []
resizeWindow :: Session -> Int -> Int -> IO ()
resizeWindow sess width height =
void $ command sess "ResizeWindow" [show' width, show' height]
where
show' = (BS.pack . show)
getVersion :: Session -> IO Text
getVersion sess =
dec $ command sess "Version" []
allText :: Session -> NodeHandle -> IO Text
allText sess h = dec $ invoke sess h "allText" []
visibleText :: Session -> NodeHandle -> IO Text
visibleText sess h = dec $ invoke sess h "text" []
findXPathRel :: Session -> NodeHandle -> Text -> IO [NodeHandle]
findXPathRel sess h query =
T.splitOn "," <$> (dec $ invoke sess h "findXpathWithin" [enc query])
findCSSRel :: Session -> NodeHandle -> Text -> IO [NodeHandle]
findCSSRel sess h query =
T.splitOn "," <$> (dec $ invoke sess h "findCssWithin" [enc query])
attr :: Session -> NodeHandle -> Text -> IO (Maybe Text)
attr sess h name = do
has <- hasAttr sess h name
if has
then do
val <- (dec $ invoke sess h "attribute" [enc name])
return $ Just val
else do
return Nothing
hasAttr :: Session -> NodeHandle -> Text -> IO Bool
hasAttr sess h name = do
val <- invoke sess h "hasAttribute" [enc name]
return $ val == "true"
value :: Session -> NodeHandle -> IO NodeValue
value sess h = do
isMult <- isMultipleSelect sess h
if isMult
then do
handles <- findXPathRel sess h ".//option"
selected <- filterM (isSelected sess) handles
values <- mapM (invoke sess h "value" . (:[]) . enc) selected
return $ MultiValue selected
else do
val <- dec $ invoke sess h "value" []
return $ SingleValue val
set :: Session -> NodeHandle -> NodeValue -> IO ()
set sess h val =
case val of
SingleValue v ->
void $ invoke sess h "set" [enc v]
MultiValue vs ->
void $ invoke sess h "set" (map enc vs)
isMultipleSelect :: Session -> NodeHandle -> IO Bool
isMultipleSelect sess h = do
name <- tagName sess h
mult <- attr sess h "multiple"
return $ mult == Just "true"
tagName :: Session -> NodeHandle -> IO Text
tagName sess h = dec $ invoke sess h "tagName" []
isSelected :: Session -> NodeHandle -> IO Bool
isSelected sess h = do
val <- invoke sess h "selected" []
return $ val == "true"
isVisible :: Session -> NodeHandle -> IO Bool
isVisible sess h = do
val <- invoke sess h "visible" []
return $ val == "true"
isChecked :: Session -> NodeHandle -> IO Bool
isChecked sess h = do
mult <- attr sess h "checked"
return $ mult == Just "true"
isDisabled :: Session -> NodeHandle -> IO Bool
isDisabled sess h = do
name <- tagName sess h
if (name == "option" || name == "optgroup")
then do
dis <- attr sess h "disabled"
if (dis == Just "true")
then return True
else do
parent <- findXPathRel sess h "parent::*"
isDisabled sess (head parent)
else do
dis <- attr sess h "disabled"
return $ dis == Just "true"
selectOption :: Session -> NodeHandle -> IO ()
selectOption sess h =
void $ invoke sess h "selectOption" []
unselectOption :: Session -> NodeHandle -> IO ()
unselectOption sess h = do
selects <- findXPathRel sess h "ancestor::select"
if (not . null $ selects)
then do
isMult <- isMultipleSelect sess (head selects)
if isMult
then void $ invoke sess h "unselectOption" []
else error "UnselectNotAllowed"
else error "UnselectNotAllowed"
click :: Session -> NodeHandle -> IO ()
click sess h =
void $ invoke sess h "leftClick" []
doubleClick :: Session -> NodeHandle -> IO ()
doubleClick sess h =
void $ invoke sess h "doubleClick" []
rightClick :: Session -> NodeHandle -> IO ()
rightClick sess h =
void $ invoke sess h "rightClick" []
hover :: Session -> NodeHandle -> IO ()
hover sess h =
void $ invoke sess h "hover" []
dragTo :: Session -> NodeHandle -> NodeHandle -> IO ()
dragTo sess h1 h2 =
void $ invoke sess h1 "dragTo" [enc h2]
path :: Session -> NodeHandle -> IO Text
path sess h =
dec $ invoke sess h "path" []
submit :: Session -> NodeHandle -> IO ()
submit sess h =
void $ invoke sess h "submit" []
trigger :: Session -> NodeHandle -> Text -> IO ()
trigger sess h event =
void $ invoke sess h "trigger" [enc event]
isAttached :: Session -> NodeHandle -> IO Bool
isAttached sess h = do
val <- command sess "Node" ["isAttached", enc h]
return $ val == "true"
nodeEq :: Session -> NodeHandle -> NodeHandle -> IO Bool
nodeEq sess h1 h2 = do
val <- invoke sess h1 "equals" [enc h2]
return $ val == "true"