packages feed

happybara-webkit (empty) → 0.0.1

raw patch · 8 files changed

+702/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, case-insensitive, data-default, directory, filepath, happybara, http-types, lifted-base, monad-control, mtl, network, process, text, time, transformers, transformers-base, vector, word8

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 Charles Strahan++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happybara-webkit.cabal view
@@ -0,0 +1,42 @@+name:                happybara-webkit+version:             0.0.1+synopsis:            WebKit Happybara driver+homepage:            https://github.com/cstrahan/happybara/happybara-webkit+license:             MIT+license-file:        LICENSE+author:              Charles Strahan+maintainer:          charles.c.strahan@gmail.com+copyright:           Copyright (c) 2014 Charles Strahan+category:            Development+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Happybara.WebKit,+                       Happybara.WebKit.Commands,+                       Happybara.WebKit.Driver,+                       Happybara.WebKit.Exceptions,+                       Happybara.WebKit.Session+  other-modules:       Paths_happybara_webkit+  build-depends:       base >=4.6 && <4.7,+                       happybara,+                       process,+                       directory,+                       network,+                       word8,+                       bytestring,+                       mtl,+                       monad-control,+                       lifted-base,+                       data-default,+                       transformers,+                       transformers-base,+                       time,+                       text,+                       http-types,+                       filepath,+                       vector,+                       aeson,+                       case-insensitive+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Happybara/WebKit.hs view
@@ -0,0 +1,8 @@+module Happybara.WebKit+    ( module Happybara.WebKit.Session+    , module Happybara.WebKit.Exceptions+    ) where++import           Happybara.WebKit.Driver     ()+import           Happybara.WebKit.Exceptions+import           Happybara.WebKit.Session
+ src/Happybara/WebKit/Commands.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE OverloadedStrings #-}++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" []+++-- NODE FUNCTIONS++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"
+ src/Happybara/WebKit/Driver.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TypeFamilies #-}++module Happybara.WebKit.Driver where++import           Data.Aeson+import           Data.ByteString             (ByteString)+import           Data.Text                   (Text)++import           Network.HTTP.Types++import           Control.Applicative+import           Control.Exception+import           Control.Monad.Base+import           Control.Monad.State+import           Control.Monad.Trans.Control++import           Happybara.Driver+import           Happybara.WebKit.Commands   as CMD+import           Happybara.WebKit.Session++instance Driver Session where+    data Node Session = WebKitNode !Text deriving (Show)+    currentUrl sess = do+        CMD.currentUrl sess+    visit sess url = CMD.visit sess url+    findXPath sess query = do+        handles <- CMD.findXPath sess query+        return $ map WebKitNode handles+    findCSS sess query = do+        handles <- CMD.findCSS sess query+        return $ map WebKitNode handles+    html sess = do+        CMD.body sess+    goBack = error "NOT IMPLEMENTED"+    goForward = error "NOT IMPLEMENTED"+    executeScript sess script = do+        CMD.executeScript sess script+    evaluateScript sess script = do+        CMD.evaluateScript sess script+    saveScreenshot sess path width height = do+        CMD.render sess path width height+    responseHeaders sess = do+        CMD.responseHeaders sess+    statusCode sess = do+        toEnum <$> CMD.statusCode sess+    setFrameFocus sess frameId = do+        CMD.setFrameFocus sess frameId+    setWindowFocus sess name = error "NOT IMPLEMENTED"+    reset sess = do+        CMD.reset sess+    findXPathRel sess (WebKitNode h) query = do+        handles <- CMD.findXPathRel sess h query+        return $ map WebKitNode handles+    findCSSRel sess (WebKitNode h) query = do+        handles <- CMD.findCSSRel sess h query+        return $ map WebKitNode handles+    allText sess (WebKitNode h) = do+        CMD.allText sess h+    visibleText sess (WebKitNode h) = do+        CMD.visibleText sess h+    attr sess (WebKitNode h) name = do+        CMD.attr sess h name+    getValue sess (WebKitNode h) = do+        CMD.value sess h+    setValue sess (WebKitNode h) val = do+        CMD.set sess h val+    selectOption sess (WebKitNode h) = do+        CMD.selectOption sess h+    unselectOption sess (WebKitNode h) = do+        CMD.unselectOption sess h+    click sess (WebKitNode h) = do+        CMD.click sess h+    rightClick sess (WebKitNode h) = do+        CMD.rightClick sess h+    doubleClick sess (WebKitNode h) = do+        CMD.doubleClick sess h+    hover sess (WebKitNode h) = do+        CMD.hover sess h+    dragTo sess (WebKitNode h1) (WebKitNode h2) = do+        CMD.dragTo sess h1 h2+    tagName sess (WebKitNode h) = do+        CMD.tagName sess h+    isVisible sess (WebKitNode h) = do+        CMD.isVisible sess h+    isChecked sess (WebKitNode h) = do+        CMD.isChecked sess h+    isSelected sess (WebKitNode h) = do+        CMD.isSelected sess h+    isDisabled sess (WebKitNode h) = do+        CMD.isDisabled sess h+    path sess (WebKitNode h) = do+        CMD.path sess h+    trigger sess (WebKitNode h) event = do+        CMD.trigger sess h event+    nodeEq sess (WebKitNode h1) (WebKitNode h2) = do+        CMD.nodeEq sess h1 h2
+ src/Happybara/WebKit/Exceptions.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}++module Happybara.WebKit.Exceptions where++import           Control.Exception+import           Data.Typeable++import           Happybara.Exceptions++data NodeNotAttachedException = NodeNotAttachedException String+    deriving (Show, Typeable)+instance Exception NodeNotAttachedException where+    toException = toException . InvalidElementException+    fromException x = do+        InvalidElementException a <- fromException x+        cast a++data TimeoutException = TimeoutException String+    deriving (Show, Typeable)+instance Exception TimeoutException where+    toException = toException . HappybaraException+    fromException x = do+        HappybaraException a <- fromException x+        cast a++data InvalidResponseException = InvalidResponseException String+    deriving (Show, Typeable)+instance Exception InvalidResponseException where+    toException = toException . HappybaraException+    fromException x = do+        HappybaraException a <- fromException x+        cast a++data NoResponseException = NoResponseException String+    deriving (Show, Typeable)+instance Exception NoResponseException where+    toException = toException . HappybaraException+    fromException x = do+        HappybaraException a <- fromException x+        cast a++data ClickFailedException = ClickFailedException String+    deriving (Show, Typeable)+instance Exception ClickFailedException where+    toException = toException . HappybaraException+    fromException x = do+        HappybaraException a <- fromException x+        cast a
+ src/Happybara/WebKit/Session.hs view
@@ -0,0 +1,74 @@+module Happybara.WebKit.Session+    ( Session(..)+    , withSession+    , mkSession+    , closeSession+    ) where++import           Data.Char                   (isDigit)+import           Data.List                   (isPrefixOf, sort)+import           Data.Maybe                  (maybe)++import           Control.Applicative+import           Control.Concurrent+import           Control.Exception++import           System.FilePath+import           System.IO+import           System.Process+import           System.Timeout++import           Network.BSD                 as Net+import           Network.HTTP.Types          (Header, ResponseHeaders, Status)+import qualified Network.Socket              as Net++import           System.Info                 (os)++data Session = Session { sock       :: Net.Socket+                       , sockHandle :: Handle+                       , procHandle :: ProcessHandle+                       }++webkitServerStartTimeout :: Int+webkitServerStartTimeout = 15 * 1000000++withSession :: FilePath -> (Session -> IO a) -> IO a+withSession serverPath fun = do+    bracket+        (mkSession serverPath)+        (closeSession)+        (fun)++mkSession :: FilePath -> IO Session+mkSession serverPath = do+    (_, sout, _, p) <- runInteractiveProcess serverPath [] Nothing Nothing+    mport <- timeout webkitServerStartTimeout (parsePort <$> hGetLine sout)+    let port = maybe noDetectError id mport+    addr <- head <$> Net.getAddrInfo Nothing (Just "localhost") (Just $ show port)+    (s, h) <- conn addr+    return $ Session { sock = s, sockHandle = h, procHandle = p }+  where+    conn addr = do+        s <- Net.socket (Net.addrFamily addr) Net.Stream defaultProtocol+        Net.setSocketOption s Net.KeepAlive 1+        Net.connect s (Net.addrAddress addr)+        h <- Net.socketToHandle s ReadWriteMode+        hSetBuffering h (BlockBuffering Nothing)+        return (s, h)+    parsePort :: String -> Int+    parsePort str =+        if prefix `isPrefixOf` str+          then port+          else noDetectError+      where+        prefix = "Capybara-webkit server started, listening on port: "+        digits = takeWhile isDigit . drop (length prefix)+        port = read $ digits str++closeSession :: Session -> IO ()+closeSession sess = do+    hClose (sockHandle sess)+    terminateProcess (procHandle sess)++noDetectError :: t+noDetectError = error "could not detect webkit_server port"