diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -XOverloadedStrings +:m Test.WebDriver Data.Default diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,26 @@ #Change Log +## hs-webdriver 0.3 + +### API changes +* 2 typeclasses were introduced. All WebDriver commands are now overloaded on WebDriver class, so that monad transformers with a WD base can be used conveniently. +* The MonadState instance of WD has been removed and replaced by SessionState. +* The Firefox profile code has been generalized to work with either Opera or Firefox profiles. A phantom type parameter is used to create a distinction between the two. See documentation on Common.Profile and Firefox.Profile to learn about the specific changes that were made. +* FFLogPref is now removed and replaced by the LogPref type, because both Firefox and Opera config use the same logging preference values. +* Several new modules have been created, including: Capabilities, Monad, Classes, Exceptions. Many of the definitions have been moved around, but the export lists of the pre-existing modules are the same. + +### Bug fixes +* Various issues with the serialization of capabilities meant that Chrome, IE, and Opera weren't able to startup correctly with default capabilities. This is now fixed. + +### new features +* General documentation improvements. +* Opera configuration is now implemented. + ## hs-webdriver 0.2 ### API changes * FailedCommandInfo changed so that it stores a WDSession rather than just a Maybe SessionId, thus providing server host and port information as well as the session ID. -* As a result, mkFailedcommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state. +* As a result, mkFailedCommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state. * HTML5StorageType changed to the more accurate WebStorageType ### new features diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ ```sh cabal install webdriver ``` -There are also options to do system-wide installation, version selection, and other build options. See Cabal documentation. +There are also options to do system-wide installation, version selection, and other build options; see cabal-install documentation. ## Installation from this repository diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,23 +1,16 @@ -for next minor releases - --- add special web-driver specific FF profile setters, either as special -functions or via documentation - --- add opera config +for next release --- improve documentation. Document errors better. Provide more -module introductions +-- improve documentation. Document errors. -- provide examples -- basic runSession usage -- intermediate usage + -- exception handling with lifted-base -- explicit waits usage -- firefox profile usage -- REPL usage - for 1.0 --- overload WD commands in typeclass -- add WDSettings, use WDSession as internal State type. -- allow settings to automatically load drivers. add modules with driver loading functions @@ -25,9 +18,15 @@ -miscellaneous unsorted +distant future -- use http-conduit and attoparsec-conduit to stream JSON data. use request methods from http-types -- use ReaderT to store WDVersion for use with implicit configurations. + +misc. unsorted + +-- remove temporary directory code from prepareProfile + +--Use lazy ByteString where possible. patch base64-bytestring to work with lazy bytestrings diff --git a/Test/WebDriver.hs b/Test/WebDriver.hs deleted file mode 100644 --- a/Test/WebDriver.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| -This module serves as the top-level interface to the Haskell WebDriver bindings, -providing most of the functionality you're likely to want. --} -module Test.WebDriver - ( -- * WebDriver sessions - WD(..), WDSession(..), defaultSession, SessionId(..) - -- * Running WebDriver tests - , module Test.WebDriver - -- * Capabilities and configuration - , Capabilities(..), defaultCaps, allCaps - , Platform(..), ProxyType(..) - -- ** Browser-specific configuration - , Browser(..), firefox, chrome, ie, opera, iPhone, iPad, android - -- * WebDriver commands - , module Test.WebDriver.Commands - -- * Exceptions - , InvalidURL(..), NoSessionId(..), BadJSON(..) - , HTTPStatusUnknown(..), HTTPConnError(..) - , UnknownCommand(..), ServerError(..) - , FailedCommand(..), FailedCommandType(..) - , FailedCommandInfo(..), StackFrame(..) - , mkFailedCommandInfo, failedCommand - ) where - -import Test.WebDriver.Types -import Test.WebDriver.Commands - -import Control.Applicative -import Control.Monad.State.Strict -import Control.Exception.Lifted - -import Prelude hiding (catch) - --- |Executes a 'WD' computation within the 'IO' monad, using the given --- 'WDSession'. -runWD :: WDSession -> WD a -> IO a -runWD sess (WD wd) = evalStateT wd sess - --- |Like 'runWD', but automatically creates a session beforehand and closes it --- afterwards. This is a very common use case. -runSession :: WDSession -> Capabilities -> WD a -> IO a -runSession s caps wd = runWD s $ createSession caps >> wd <* closeSession - --- |Locally sets a 'WDSession' for use within the given 'WD' action. --- The state of the outer action is unaffected by this function. --- This function is useful if you need to work with multiple sessions at once. -withSession :: WDSession -> WD a -> WD a -withSession s' (WD wd) = WD . lift $ evalStateT wd s' - --- |A finalizer ensuring that the session is always closed at the end of --- the given 'WD' action, regardless of any exceptions. -finallyClose:: WD a -> WD a -finallyClose wd = closeOnException wd <* closeSession - --- |A variant of 'finallyClose' that only closes the session when an --- asynchronous exception is thrown, but otherwise leaves the session open --- if the action was successful. -closeOnException :: WD a -> WD a -closeOnException wd = wd `onException` closeSession diff --git a/Test/WebDriver/Chrome/Extension.hs b/Test/WebDriver/Chrome/Extension.hs deleted file mode 100644 --- a/Test/WebDriver/Chrome/Extension.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Test.WebDriver.Chrome.Extension - ( ChromeExtension - , loadExtension - , loadRawExtension - ) where -import Data.ByteString as BS -import Data.ByteString.Base64 as B64 -import Data.Aeson -import Control.Applicative -import Control.Monad.IO.Class - --- |An opaque type representing a Google Chrome extension. -newtype ChromeExtension = ChromeExtension ByteString - deriving (Eq, Show, Read, ToJSON, FromJSON) - --- |Load a .crx file as a ChromeExtension -loadExtension :: MonadIO m => FilePath -> m ChromeExtension -loadExtension path = liftIO $ loadRawExtension <$> BS.readFile path - --- |Load raw .crx data as a ChromeExtension -loadRawExtension :: ByteString -> ChromeExtension -loadRawExtension = ChromeExtension . B64.encode diff --git a/Test/WebDriver/Commands.hs b/Test/WebDriver/Commands.hs deleted file mode 100644 --- a/Test/WebDriver/Commands.hs +++ /dev/null @@ -1,565 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} --- |This module exports basic WD actions that can be used to interact with a --- browser session. -module Test.WebDriver.Commands - ( -- * Sessions - createSession, closeSession, sessions, getCaps - -- * Browser interaction - -- ** Web navigation - , openPage, forward, back, refresh - -- ** Page info - , getCurrentURL, getSource, getTitle, screenshot - -- * Timeouts - , setImplicitWait, setScriptTimeout, setPageLoadTimeout - -- * Web elements - , Element(..), Selector(..) - -- ** Searching for elements - , findElem, findElems, findElemFrom, findElemsFrom - -- ** Interacting with elements - , click, submit, getText - , sendKeys, sendRawKeys, clearInput - -- ** Element information - , attr, cssProp, elemPos, elemSize - , isSelected, isEnabled, isDisplayed - , tagName, activeElem, elemInfo - -- ** Element equality - , (<==>), () - -- * Javascript - , executeJS, asyncJS - , JSArg(..) - -- * Windows - , WindowHandle(..), currentWindow - , getCurrentWindow, closeWindow, windows, focusWindow, maximize - , getWindowSize, setWindowSize, getWindowPos, setWindowPos - -- * Focusing on frames - , focusFrame, FrameSelector(..) - -- * Cookies - , Cookie(..), mkCookie - , cookies, setCookie, deleteCookie, deleteVisibleCookies - -- * Alerts - , getAlertText, replyToAlert, acceptAlert, dismissAlert - -- * Mouse gestures - , moveTo, moveToCenter, moveToFrom - , clickWith, MouseButton(..) - , mouseDown, mouseUp, withMouseDown, doubleClick - -- * Screen orientation - , Orientation(..) - , getOrientation, setOrientation - -- * Geo-location - , getLocation, setLocation - -- * HTML 5 Web Storage - , storageSize, getAllKeys, deleteAllKeys, getKey, setKey, deleteKey - -- * Uploading files to remote server - -- |These functions allow you to upload a file to a remote server. - -- Note that this operation isn't supported by all WebDriver servers, - -- and the location where the file is stored is not standardized. - , uploadFile, uploadRawFile, uploadZipEntry - -- * Touch gestures - , touchClick, touchDown, touchUp, touchMove - , touchScroll, touchScrollFrom, touchDoubleClick - , touchLongClick, touchFlick, touchFlickFrom - -- * IME support - , availableIMEEngines, activeIMEEngine, checkIMEActive - , activateIME, deactivateIME - -- * Server information - , serverStatus - ) where - -import Test.WebDriver.Types -import Test.WebDriver.Commands.Internal -import Test.WebDriver.JSON - -import Data.Aeson -import qualified Data.Text as T -import Data.Text (Text, splitOn, append) -import Data.ByteString as SBS (ByteString, concat) -import Data.ByteString.Base64 as B64 -import Data.ByteString.Lazy as LBS (ByteString, toChunks) -import Network.URI -import Codec.Archive.Zip - -import Control.Applicative -import Control.Monad.State.Strict -import Control.Exception (SomeException) -import Control.Exception.Lifted (throwIO, catch, handle) -import Data.Word - -import Prelude hiding (catch) - - --- |Get information from the server as a JSON 'Object'. For more information --- about this object see --- -serverStatus :: WD Value -- todo: make this a record type -serverStatus = doCommand GET "/status" () - - --- |Create a new session with the given 'Capabilities'. This command --- resets the current session ID to that of the new session. -createSession :: Capabilities -> WD WDSession -createSession caps = do - sessUrl <- doCommand POST "/session" . single "desiredCapabilities" $ caps - let sessId = SessionId . last . filter (not . T.null) . splitOn "/" $ sessUrl - modify $ \sess -> sess {wdSessId = Just sessId} - return =<< get - --- |Retrieve a list of active sessions and their 'Capabilities'. -sessions :: WD [(SessionId, Capabilities)] -sessions = do - objs <- doCommand GET "/sessions" () - forM objs $ parsePair "id" "capabilities" "sessions" - --- |Get the actual 'Capabilities' of the current session. -getCaps :: WD Capabilities -getCaps = doSessCommand GET "" () - --- |Close the current session and the browser associated with it. -closeSession :: WD () -closeSession = do s <- get - doSessCommand DELETE "" () :: WD () - put s { wdSessId = Nothing } - --- |Sets the amount of time we implicitly wait when searching for 'Elements'. -setImplicitWait :: Integer -> WD () -setImplicitWait ms = - doSessCommand POST "/timeouts/implicit_wait" (object msField) - `catch` \(_ :: SomeException) -> - doSessCommand POST "/timeouts" (object allFields) - where msField = ["ms" .= ms] - allFields = ["type" .= ("implicit" :: String)] ++ msField - --- |Sets the amount of time we wait for an asynchronous script to return a --- result. -setScriptTimeout :: Integer -> WD () -setScriptTimeout ms = - doSessCommand POST "/timeouts/async_script" (object msField) - `catch` \(_ :: SomeException) -> - doSessCommand POST "/timeouts" (object allFields) - where msField = ["ms" .= ms] - allFields = ["type" .= ("script" :: String)] ++ msField - --- |Sets the amount of time to wait for a page to finish loading before throwing a 'Timeout' exception -setPageLoadTimeout :: Integer -> WD () -setPageLoadTimeout ms = doSessCommand POST "/timeouts" params - where params = object ["type" .= ("page load" :: String) - ,"ms" .= ms ] - --- |Gets the URL of the current page. -getCurrentURL :: WD String -getCurrentURL = doSessCommand GET "/url" () - --- |Opens a new page by the given URL. -openPage :: String -> WD () -openPage url - | isURI url = doSessCommand POST "/url" . single "url" $ url - | otherwise = throwIO . InvalidURL $ url - --- |Navigate forward in the browser history. -forward :: WD () -forward = doSessCommand POST "/forward" () - --- |Navigate backward in the browser history. -back :: WD () -back = doSessCommand POST "/back" () - --- |Refresh the current page -refresh :: WD () -refresh = doSessCommand POST "/refresh" () - -{- |Inject a snippet of Javascript into the page for execution in the -context of the currently selected frame. The executed script is -assumed to be synchronous and the result of evaluating the script is -returned and converted to an instance of FromJSON. - -The first parameter defines arguments to pass to the javascript -function. Arguments of type Element will be converted to the -corresponding DOM element. Likewise, any elements in the script result -will be returned to the client as Elements. - -The second parameter defines the script itself in the form of a -function body. The value returned by that function will be returned to -the client. The function will be invoked with the provided argument -list and the values may be accessed via the arguments object in the -order specified. --} -executeJS :: FromJSON a => [JSArg] -> Text -> WD a -executeJS a s = fromJSON' =<< getResult - where - getResult = doSessCommand POST "/execute" . pair ("args", "script") $ (a,s) - -{- |Executes a snippet of Javascript code asynchronously. This function works -similarly to 'executeJS', except that the Javascript is passed a callback -function as its final argument. The script should call this function -to signal that it has finished executing, passing to it a value that will be -returned as the result of asyncJS. A result of Nothing indicates that the -Javascript function timed out (see 'setScriptTimeout') --} -asyncJS :: FromJSON a => [JSArg] -> Text -> WD (Maybe a) -asyncJS a s = handle timeout $ fromJSON' =<< getResult - where - getResult = doSessCommand POST "/execute_async" . pair ("args", "script") - $ (a,s) - timeout (FailedCommand Timeout _) = return Nothing - timeout err = throwIO err - --- |Grab a screenshot of the current page as a PNG image -screenshot :: WD SBS.ByteString -screenshot = B64.decodeLenient <$> doSessCommand GET "/screenshot" () - - -availableIMEEngines :: WD [Text] -availableIMEEngines = doSessCommand GET "/ime/available_engines" () - -activeIMEEngine :: WD Text -activeIMEEngine = doSessCommand GET "/ime/active_engine" () - -checkIMEActive :: WD Bool -checkIMEActive = doSessCommand GET "/ime/activated" () - -activateIME :: Text -> WD () -activateIME = doSessCommand POST "/ime/activate" . single "engine" - -deactivateIME :: WD () -deactivateIME = doSessCommand POST "/ime/deactivate" () - --- |Switch focus to the frame specified by the FrameSelector. -focusFrame :: FrameSelector -> WD () -focusFrame s = doSessCommand POST "/frame" . single "id" $ s - --- |Returns a handle to the currently focused window -getCurrentWindow :: WD WindowHandle -getCurrentWindow = doSessCommand GET "/window_handle" () - --- |Returns a list of all windows available to the session -windows :: WD [WindowHandle] -windows = doSessCommand GET "/window_handles" () - -focusWindow :: WindowHandle -> WD () -focusWindow w = doSessCommand POST "/window" . single "name" $ w - --- |Closes the given window -closeWindow :: WindowHandle -> WD () -closeWindow = doSessCommand DELETE "/window" . single "name" - --- |Maximizes the current window if not already maximized -maximize :: WD () -maximize = doWinCommand GET currentWindow "/maximize" () - --- |Get the dimensions of the current window. -getWindowSize :: WD (Word, Word) -getWindowSize = doWinCommand GET currentWindow "/size" () - >>= parsePair "width" "height" "getWindowSize" - --- |Set the dimensions of the current window. -setWindowSize :: (Word, Word) -> WD () -setWindowSize = doWinCommand POST currentWindow "/size" - . pair ("width", "height") - --- |Get the coordinates of the current window. -getWindowPos :: WD (Int, Int) -getWindowPos = doWinCommand GET currentWindow "/position" () - >>= parsePair "x" "y" "getWindowPos" - --- |Set the coordinates of the current window. -setWindowPos :: (Int, Int) -> WD () -setWindowPos = doWinCommand POST currentWindow "/position" . pair ("x","y") - --- |Retrieve all cookies visible to the current page. -cookies :: WD [Cookie] -cookies = doSessCommand GET "/cookie" () - --- |Set a cookie. If the cookie path is not specified, it will default to \"/\". --- Likewise, if the domain is omitted, it will default to the current page's --- domain -setCookie :: Cookie -> WD () -setCookie = doSessCommand POST "/cookie" . single "cookie" - --- |Delete a cookie. This will do nothing is the cookie isn't visible to the --- current page. -deleteCookie :: Cookie -> WD () -deleteCookie c = doSessCommand DELETE ("/cookie/" `append` cookName c) () - --- |Delete all visible cookies on the current page. -deleteVisibleCookies :: WD () -deleteVisibleCookies = doSessCommand DELETE "/cookie" () - --- |Get the current page source -getSource :: WD Text -getSource = doSessCommand GET "/source" () - --- |Get the title of the current page. -getTitle :: WD Text -getTitle = doSessCommand GET "/title" () - --- |Find an element on the page using the given element selector. -findElem :: Selector -> WD Element -findElem = doSessCommand POST "/element" - --- |Find all elements on the page matching the given selector. -findElems :: Selector -> WD [Element] -findElems = doSessCommand POST "/elements" - --- |Return the element that currently has focus. -activeElem :: WD Element -activeElem = doSessCommand POST "/element/active" () - --- |Search for an element using the given element as root. -findElemFrom :: Element -> Selector -> WD Element -findElemFrom e = doElemCommand POST e "/element" - --- |Find all elements matching a selector, using the given element as root. -findElemsFrom :: Element -> Selector -> WD [Element] -findElemsFrom e = doElemCommand POST e "/elements" - --- |Describe the element. Returns a JSON object whose meaning is currently --- undefined by the WebDriver protocol. -elemInfo :: Element -> WD Value -elemInfo e = doElemCommand GET e "" () - --- |Click on an element. -click :: Element -> WD () -click e = doElemCommand POST e "/click" () - --- |Submit a form element. This may be applied to descendents of a form element --- as well. -submit :: Element -> WD () -submit e = doElemCommand POST e "/submit" () - --- |Get all visible text within this element. -getText :: Element -> WD Text -getText e = doElemCommand GET e "/text" () - --- |Send a sequence of keystrokes to an element. All modifier keys are released --- at the end of the function. For more information about modifier keys, see --- -sendKeys :: Text -> Element -> WD () -sendKeys t e = doElemCommand POST e "/value" . single "value" $ [t] - --- |Similar to sendKeys, but doesn't implicitly release modifier keys --- afterwards. This allows you to combine modifiers with mouse clicks. -sendRawKeys :: Text -> Element -> WD () -sendRawKeys t e = doElemCommand POST e "/keys" . single "value" $ [t] - --- |Return the tag name of the given element. -tagName :: Element -> WD Text -tagName e = doElemCommand GET e "/name" () - --- |Clear a textarea or text input element's value. -clearInput :: Element -> WD () -clearInput e = doElemCommand POST e "/clear" () - --- |Determine if the element is selected. -isSelected :: Element -> WD Bool -isSelected e = doElemCommand GET e "/selected" () - --- |Determine if the element is enabled. -isEnabled :: Element -> WD Bool -isEnabled e = doElemCommand GET e "/enabled" () - --- |Determine if the element is displayed. -isDisplayed :: Element -> WD Bool -isDisplayed e = doElemCommand GET e "/displayed" () - --- |Retrieve the value of an element's attribute -attr :: Element -> Text -> WD (Maybe Text) -attr e t = doElemCommand GET e ("/attribute/" `append` t) () - --- |Retrieve the value of an element's computed CSS property -cssProp :: Element -> Text -> WD (Maybe Text) -cssProp e t = doElemCommand GET e ("/css/" `append` t) () - --- |Retrieve an element's current position. -elemPos :: Element -> WD (Int, Int) -elemPos e = doElemCommand GET e "/location" () >>= parsePair "x" "y" "elemPos" - --- |Retrieve an element's current size. -elemSize :: Element -> WD (Word, Word) -elemSize e = doElemCommand GET e "/size" () - >>= parsePair "width" "height" "elemSize" - -infix 4 <==> --- |Determines if two element identifiers refer to the same element. -(<==>) :: Element -> Element -> WD Bool -e1 <==> (Element e2) = doElemCommand GET e1 ("/equals/" `append` e2) () - --- |Determines if two element identifiers refer to different elements. -infix 4 -() :: Element -> Element -> WD Bool -e1 e2 = not <$> (e1 <==> e2) - --- |Get the current screen orientation for rotatable display devices. -getOrientation :: WD Orientation -getOrientation = doSessCommand GET "/orientation" () - --- |Set the current screen orientation for rotatable display devices. -setOrientation :: Orientation -> WD () -setOrientation = doSessCommand POST "/orientation" . single "orientation" - --- |Get the text of an alert dialog. -getAlertText :: WD Text -getAlertText = doSessCommand GET "/alert_text" () - --- |Sends keystrokes to Javascript prompt() dialog. -replyToAlert :: Text -> WD () -replyToAlert = doSessCommand POST "/alert_text" . single "text" - --- |Accepts the currently displayed alert dialog. -acceptAlert :: WD () -acceptAlert = doSessCommand POST "/accept_alert" () - --- |Dismisses the currently displayed alert dialog. -dismissAlert :: WD () -dismissAlert = doSessCommand POST "/dismiss_alert" () - --- |Moves the mouse to the given position relative to the active element. -moveTo :: (Int, Int) -> WD () -moveTo = doSessCommand POST "/moveto" . pair ("xoffset","yoffset") - --- |Moves the mouse to the center of a given element. -moveToCenter :: Element -> WD () -moveToCenter (Element e) = - doSessCommand POST "/moveto" . single "element" $ e - --- |Moves the mouse to the given position relative to the given element. -moveToFrom :: (Int, Int) -> Element -> WD () -moveToFrom (x,y) (Element e) = - doSessCommand POST "/moveto" - . triple ("element","xoffset","yoffset") $ (e,x,y) - --- |Click at the current mouse position with the given mouse button. -clickWith :: MouseButton -> WD () -clickWith = doSessCommand POST "/click" . single "button" - --- |Perform the given action with the left mouse button held down. The mouse --- is automatically released afterwards. -withMouseDown :: WD a -> WD a -withMouseDown wd = mouseDown >> wd <* mouseUp - --- |Press and hold the left mouse button down. Note that undefined behavior --- occurs if the next mouse command is not mouseUp. -mouseDown :: WD () -mouseDown = doSessCommand POST "/buttondown" () - --- |Release the left mouse button. -mouseUp :: WD () -mouseUp = doSessCommand POST "/buttonup" () - --- |Double click at the current mouse location. -doubleClick :: WD () -doubleClick = doSessCommand POST "/doubleclick" () - --- |Single tap on the touch screen at the given element's location. -touchClick :: Element -> WD () -touchClick (Element e) = - doSessCommand POST "/touch/click" . single "element" $ e - --- |Emulates pressing a finger down on the screen at the given location. -touchDown :: (Int, Int) -> WD () -touchDown = doSessCommand POST "/touch/down" . pair ("x","y") - --- |Emulates removing a finger from the screen at the given location. -touchUp :: (Int, Int) -> WD () -touchUp = doSessCommand POST "/touch/up" . pair ("x","y") - --- |Emulates moving a finger on the screen to the given location. -touchMove :: (Int, Int) -> WD () -touchMove = doSessCommand POST "/touch/move" . pair ("x","y") - --- |Emulate finger-based touch scroll. Use this function if you don't care where --- the scroll begins -touchScroll :: (Int, Int) -> WD () -touchScroll = doSessCommand POST "/touch/scroll" . pair ("xoffset","yoffset") - --- |Emulate finger-based touch scroll, starting from the given location relative --- to the given element. -touchScrollFrom :: (Int, Int) -> Element -> WD () -touchScrollFrom (x, y) (Element e) = - doSessCommand POST "/touch/scroll" - . triple ("xoffset", "yoffset", "element") - $ (x, y, e) - --- |Emulate a double click on a touch device. -touchDoubleClick :: Element -> WD () -touchDoubleClick (Element e) = doSessCommand POST "/touch/doubleclick" - . single "element" $ e - --- |Emulate a long click on a touch device. -touchLongClick :: Element -> WD () -touchLongClick (Element e) = doSessCommand POST "/touch/longclick" - . single "element" $ e --- |Emulate a flick on the touch screen. The coordinates indicate x and y --- velocity, respectively. Use this function if you don't care where the --- flick starts. -touchFlick :: (Int, Int) -> WD () -touchFlick = doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed") - --- |Emulate a flick on the touch screen. -touchFlickFrom :: Int -- ^ flick velocity - -> (Int, Int) -- ^ a location relative to the given element - -> Element -- ^ the given element - -> WD () -touchFlickFrom s (x,y) (Element e) = - doSessCommand POST "/touch/flick" . object $ - ["xoffset" .= x - ,"yoffset" .= y - ,"speed" .= s - ,"element" .= e - ] - --- |Get the current geographical location of the device. -getLocation :: WD (Int, Int, Int) -getLocation = doSessCommand GET "/location" () - >>= parseTriple "latitude" "longitude" "altitude" "getLocation" - --- |Set the current geographical location of the device. -setLocation :: (Int, Int, Int) -> WD () -setLocation = doSessCommand POST "/location" . triple ("latitude", - "longitude", - "altitude") - --- |Uploads a file from the local filesystem by its file path. -uploadFile :: FilePath -> WD () -uploadFile path = uploadZipEntry =<< liftIO (readEntry [] path) - --- |Uploads a raw bytestring with associated file info. -uploadRawFile :: FilePath -- ^File path to use with this bytestring. - -> Integer -- ^Modification time - -- (in seconds since Unix epoch). - -> LBS.ByteString -- ^ The file contents as a lazy ByteString - -> WD () -uploadRawFile path t str = uploadZipEntry (toEntry path t str) - - --- |Lowest level interface to the file uploading mechanism. --- This allows you to specify the exact details of --- the zip entry sent across network. -uploadZipEntry :: Entry -> WD () -uploadZipEntry = doSessCommand POST "/file" . single "file" - . B64.encode . SBS.concat . toChunks - . fromArchive . (`addEntryToArchive` emptyArchive) - --- |Get the current number of keys in a web storage area. -storageSize :: WebStorageType -> WD Integer -storageSize s = doStorageCommand GET s "/size" () - --- |Get a list of all keys from a web storage area. -getAllKeys :: WebStorageType -> WD [Text] -getAllKeys s = doStorageCommand GET s "" () - --- |Delete all keys within a given web storage area. -deleteAllKeys :: WebStorageType -> WD () -deleteAllKeys s = doStorageCommand DELETE s "" () - --- |Get the value associated with a key in the given web storage area. --- Unset keys result in empty strings, since the Web Storage spec --- makes no distinction between the empty string and an undefined value. -getKey :: WebStorageType -> Text -> WD Text -getKey s k = doStorageCommand GET s ("/key/" `T.append` k) () - --- |Set a key in the given web storage area. -setKey :: WebStorageType -> Text -> Text -> WD Text -setKey s k v = doStorageCommand POST s "" . object $ ["key" .= k, - "value" .= v ] --- |Delete a key in the given web storage area. -deleteKey :: WebStorageType -> Text -> WD () -deleteKey s k = doStorageCommand POST s ("/key/" `T.append` k) () diff --git a/Test/WebDriver/Commands/Internal.hs b/Test/WebDriver/Commands/Internal.hs deleted file mode 100644 --- a/Test/WebDriver/Commands/Internal.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Test.WebDriver.Commands.Internal - ( RequestMethod(..), Header(..) - , module Test.WebDriver.Commands.Internal - ) where - -import Test.WebDriver.Types -import Test.WebDriver.Internal -import Data.Aeson -import Network.HTTP (RequestMethod(..), Header(..)) - -import qualified Data.Text as T -import Data.Text (Text) - -import Control.Monad.State.Strict (get) -import Control.Exception.Lifted (throwIO) - - -doCommand :: (ToJSON a, FromJSON b) => RequestMethod -> Text -> a -> WD b -doCommand = doCommand' [] - -doSessCommand :: (ToJSON a, FromJSON b) => RequestMethod -> Text -> a -> WD b -doSessCommand = doSessCommand' [] - -doElemCommand :: (ToJSON a, FromJSON b) => - RequestMethod -> Element -> Text -> a -> WD b -doElemCommand = doElemCommand' [] - -doWinCommand :: (ToJSON a, FromJSON b) => - RequestMethod -> WindowHandle -> Text -> a -> WD b -doWinCommand = doWinCommand' [] - -doStorageCommand :: (ToJSON a, FromJSON b) => - RequestMethod -> WebStorageType -> Text -> a -> WD b -doStorageCommand = doStorageCommand' [] - -doCommand' :: (ToJSON a, FromJSON b) => - [Header] -> RequestMethod -> Text -> a -> WD b -doCommand' headers method path args = do - r <- mkRequest headers method path args - --liftIO . print $ r - handleHTTPErr r - --liftIO . print . rspBody $ r - handleHTTPResp r - -doSessCommand' :: (ToJSON a, FromJSON b) => - [Header] -> RequestMethod -> Text -> a -> WD b -doSessCommand' headers method path args = do - WDSession { wdSessId = mSessId } <- get - case mSessId of - Nothing -> throwIO . NoSessionId $ msg - where - msg = "No session ID found when making request for relative URL " - ++ show path - Just (SessionId sId) -> doCommand' headers method - (T.concat ["/session/", sId, path]) args - -doWinCommand' :: (ToJSON a, FromJSON b) => - [Header] -> RequestMethod -> WindowHandle -> Text -> a - -> WD b -doWinCommand' h m (WindowHandle w) path a = - doSessCommand' h m (T.concat ["/window/", w, path]) a - -doElemCommand' :: (ToJSON a, FromJSON b) => - [Header] -> RequestMethod -> Element -> Text -> a -> WD b -doElemCommand' h m (Element e) path a = - doSessCommand' h m (T.concat ["/element/", e, path]) a - -doStorageCommand' :: (ToJSON a, FromJSON b) => - [Header] -> RequestMethod -> WebStorageType -> Text -> a - -> WD b -doStorageCommand' h m s path a = doSessCommand' h m (T.concat ["/", s', path]) a - where s' = case s of - LocalStorage -> "local_storage" - SessionStorage -> "session_storage" diff --git a/Test/WebDriver/Commands/Wait.hs b/Test/WebDriver/Commands/Wait.hs deleted file mode 100644 --- a/Test/WebDriver/Commands/Wait.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -module Test.WebDriver.Commands.Wait - ( -- * Expected conditions - ExpectFailed, expect, unexpected - -- ** Convenience functions - , expectAny, expectAll - , (<||>), (<&&>) - - -- * Wait on expected conditions - , waitUntil, waitUntil' - , waitWhile, waitWhile' - ) where -import Test.WebDriver.Types -import Control.Monad -import Control.Monad.IO.Class -import Control.Exception.Lifted -import Control.Concurrent -import Data.Time.Clock -import Data.Typeable -import Prelude hiding (catch) - -instance Exception ExpectFailed --- |An exception representing the failure of an expected condition. -data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable) - --- |throws 'ExpectFailed'. This is nice for writing your own abstractions. -unexpected :: WD a -unexpected = throwIO ExpectFailed - --- |An expected condition. This function allows you to express assertions in --- your explicit wait. This function raises 'ExpectFailed' if the given --- boolean is False, and otherwise does nothing. -expect :: Bool -> WD () -expect b - | b = return () - | otherwise = unexpected - - --- |Lifted boolean and -(<&&>) :: Monad m => m Bool -> m Bool -> m Bool -(<&&>) = liftM2 (&&) - --- |Lifted boolean or -(<||>) :: Monad m => m Bool -> m Bool -> m Bool -(<||>) = liftM2 (||) - - --- |Apply a predicate to every element in a list, and expect that at least one --- succeeds. -expectAny :: (a -> WD Bool) -> [a] -> WD () -expectAny p xs = expect . or =<< mapM p xs - --- |Apply a predicate to every element in a list, and expect that all succeed. -expectAll :: (a -> WD Bool) -> [a] -> WD () -expectAll p xs = expect . and =<< mapM p xs - --- |Wait until either the given action succeeds or the timeout is reached. --- The action will be retried every .25 seconds until no ExpectFailed or --- NoSuchElement exceptions occur. If the timeout is reached, then a --- 'Test.WebDriver.Timeout' exception will be raised. The timeout value is --- expressed in seconds. -waitUntil :: Double -> WD a -> WD a -waitUntil = waitUntil' 250000 - --- |Similar to waitUntil but allows you to also specify the poll frequency --- of the WD action. The frequency is expressed as an integer in microseconds. -waitUntil' :: Int -> Double -> WD a -> WD a -waitUntil' = wait' handler - where - handler retry = (`catches` [Handler handleFailedCommand - ,Handler handleExpectFailed] - ) - where - handleFailedCommand (FailedCommand NoSuchElement _) = retry - handleFailedCommand err = throwIO err - - handleExpectFailed (_ :: ExpectFailed) = retry - --- |Like 'waitUntil', but retries the action until it fails or until the timeout --- is exceeded. -waitWhile :: Double -> WD a -> WD () -waitWhile = waitWhile' 250000 - --- |Like 'waitUntil\'', but retries the action until it either fails or --- until the timeout is exceeded. -waitWhile' :: Int -> Double -> WD a -> WD () -waitWhile' = wait' handler - where - handler retry wd = do - void wd `catches` [Handler handleFailedCommand - ,Handler handleExpectFailed - ] - retry - where - handleFailedCommand (FailedCommand NoSuchElement _) = return () - handleFailedCommand err = throwIO err - - handleExpectFailed (_ :: ExpectFailed) = return () - -wait' :: (WD b -> WD a -> WD b) -> Int -> Double -> WD a -> WD b -wait' handler waitAmnt t wd = waitLoop =<< liftIO getCurrentTime - where timeout = realToFrac t - waitLoop startTime = handler retry wd - where - retry = do - now <- liftIO getCurrentTime - if diffUTCTime now startTime >= timeout - then - failedCommand Timeout "waitUntil': explicit wait timed out." - else do - liftIO . threadDelay $ waitAmnt - waitLoop startTime diff --git a/Test/WebDriver/Firefox/Profile.hs b/Test/WebDriver/Firefox/Profile.hs deleted file mode 100644 --- a/Test/WebDriver/Firefox/Profile.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE CPP, TypeSynonymInstances, OverloadedStrings, - GeneralizedNewtypeDeriving, DeriveDataTypeable, - FlexibleInstances #-} --- |A module for working with Firefox profiles. Firefox profiles are manipulated --- in pure code and then \"prepared\" for network transmission. -module Test.WebDriver.Firefox.Profile - ( -- * Profiles - FirefoxProfile(..), PreparedFirefoxProfile - -- * Preferences - , FirefoxPref(..), ToFirefox(..) - , addPref, getPref, deletePref - -- * Extensions - , addExtension, deleteExtension - -- * Loading and preparing profiles - , loadProfile, prepareProfile - , prepareTempProfile, prepareLoadedProfile - ) where -import Data.Aeson -import Data.Attoparsec.Text as AP -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.Text (Text, pack) -import Data.Text.IO as TIO -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as SBS -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.ByteString.Base64 as B64 - -import Data.Fixed -import Data.Ratio -import Data.Int -import Data.Word -import Data.Char - -import System.IO -import System.FilePath hiding (hasExtension, addExtension) -import System.Directory -import System.IO.Temp -import Codec.Archive.Zip -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Control.Monad -import Control.Applicative -import Control.Monad.IO.Class -import Control.Exception.Lifted -import Data.Typeable - --- |This structure allows you to --- construct and manipulate Firefox profiles in pure code, deferring execution --- of IO operations until the profile is \"prepared\" using either --- 'prepareProfile' or one of the wrapper functions 'prepareTempProfile' and --- 'prepareLoadedProfile'. -data FirefoxProfile = FirefoxProfile - { -- |Location of the profile in the local file system - profileDir :: FilePath - -- |A set of filepaths pointing to Firefox extensions. - -- These paths can either refer to an .xpi file - -- or an extension directory - , profileExts :: HS.HashSet FilePath - -- |A map of Firefox preferences. These are the settings - -- found in the profile's prefs.js, and entries found in - -- about:config - , profilePrefs :: HM.HashMap Text FirefoxPref - } - deriving (Eq, Show) - - --- |Represents a Firefox profile that has been prepared for --- network transmission. The profile cannot be modified in this form. -newtype PreparedFirefoxProfile = PreparedFirefoxProfile ByteString - deriving (Eq, Show, ToJSON, FromJSON) - --- |A Firefox preference value. This is the subset of JSON values that excludes --- arrays and objects. -data FirefoxPref = PrefInteger !Integer - | PrefDouble !Double - | PrefString !Text - | PrefBool !Bool - deriving (Eq, Show) - -instance ToJSON FirefoxPref where - toJSON v = case v of - PrefInteger i -> toJSON i - PrefDouble d -> toJSON d - PrefString s -> toJSON s - PrefBool b -> toJSON b - - - -instance Exception ProfileParseError --- |An error occured while attempting to parse a profile's prefs.js file -newtype ProfileParseError = ProfileParseError String - deriving (Eq, Show, Read, Typeable) - --- |A typeclass to convert types to Firefox preference values -class ToFirefox a where - toFirefox :: a -> FirefoxPref - -instance ToFirefox Text where - toFirefox = PrefString - -instance ToFirefox String where - toFirefox = toFirefox . pack - -instance ToFirefox Bool where - toFirefox = PrefBool - -instance ToFirefox Integer where - toFirefox = PrefInteger - -#define I(t) instance ToFirefox t where toFirefox = PrefInteger . toInteger - -I(Int) -I(Int8) -I(Int16) -I(Int32) -I(Int64) -I(Word) -I(Word8) -I(Word16) -I(Word32) -I(Word64) - -instance ToFirefox Double where - toFirefox = PrefDouble - -instance ToFirefox Float where - toFirefox = PrefDouble . realToFrac - -instance (Integral a) => ToFirefox (Ratio a) where - toFirefox = PrefDouble . realToFrac - -instance (HasResolution r) => ToFirefox (Fixed r) where - toFirefox = PrefDouble . realToFrac - --- |Retrieve a preference from a profile by key name. -getPref :: Text -> FirefoxProfile -> Maybe FirefoxPref -getPref k (FirefoxProfile _ _ m) = HM.lookup k m - --- |Add a new preference entry to a profile, overwriting any existing entry --- with the same key. -addPref :: ToFirefox a => Text -> a -> FirefoxProfile -> FirefoxProfile -addPref k v p = asMap p $ HM.insert k (toFirefox v) - --- |Delete an existing preference entry from a profile. This operation is --- silent if the preference wasn't found. -deletePref :: Text -> FirefoxProfile -> FirefoxProfile -deletePref k p = asMap p $ HM.delete k - --- |Add a new extension to the profile. The file path should refer to --- an .xpi file or an extension directory. This operation has no effect if --- the same extension has already been added to this profile. -addExtension :: FilePath -> FirefoxProfile -> FirefoxProfile -addExtension path p = asSet p $ HS.insert path - --- |Delete an existing extension from the profile. The file path should refer --- to an .xpi file or an extension directory. This operation has no effect if --- the extension was never added to the profile. -deleteExtension :: FilePath -> FirefoxProfile -> FirefoxProfile -deleteExtension path p = asSet p $ HS.delete path - -asMap :: FirefoxProfile - -> (HM.HashMap Text FirefoxPref -> HM.HashMap Text FirefoxPref) - -> FirefoxProfile -asMap (FirefoxProfile p hs hm) f = FirefoxProfile p hs (f hm) - -asSet :: FirefoxProfile - -> (HS.HashSet FilePath -> HS.HashSet FilePath) - -> FirefoxProfile -asSet (FirefoxProfile p hs hm) f = FirefoxProfile p (f hs) hm - - -tempProfile :: MonadIO m => m FirefoxProfile -tempProfile = liftIO $ defaultProfile <$> mkTemp - --- |Load an existing profile from the file system. Any prepared changes made to --- the FirefoxProfile will have no effect to the profile on disk. -loadProfile :: MonadIO m => FilePath -> m FirefoxProfile -loadProfile path = liftIO $ do - FirefoxProfile{ profileDir = d } <- tempProfile - FirefoxProfile <$> pure d <*> getExtensions <*> getPrefs - where - extD = path "extensions" - userPref = path "prefs" <.> "js" - getExtensions = HS.fromList . filter (`elem` [".",".."]) - <$> getDirectoryContents extD - getPrefs = HM.fromList <$> (parsePrefs =<< TIO.readFile userPref) - - parsePrefs s = either (throwIO . ProfileParseError) - return - $ parseOnly prefsParser s - --- |Prepare a FirefoxProfile for network transmission. --- Internally, this function constructs a Firefox profile within a temp --- directory, archives it as a zip file, and then base64 encodes the zipped --- data. The temporary directory is deleted afterwards -prepareProfile :: MonadIO m => FirefoxProfile -> m PreparedFirefoxProfile -prepareProfile FirefoxProfile {profileDir = d, profileExts = s, - profilePrefs = m} - = liftIO $ do - createDirectoryIfMissing False extensionD - extPaths <- mapM canonicalizePath . HS.toList $ s - forM_ extPaths installExtension - withFile userPrefs WriteMode writeUserPrefs - prof <- PreparedFirefoxProfile . B64.encode . SBS.concat . LBS.toChunks - . fromArchive - <$> addFilesToArchive [OptRecursive] emptyArchive [d] - removeDirectoryRecursive d - return prof - where - extensionD = d "extensions" - userPrefs = d "prefs" <.> "js" - - installExtension ePath = - case splitExtension ePath of - (_,".xpi") -> installOrdinaryFile silent ePath dest - _ -> installDirectoryContents silent ePath dest - where - dest = extensionD eFile - (_,eFile) = splitFileName ePath - - writeUserPrefs h = - forM_ (HM.toList m) $ \(k, v) -> - LBS.hPut h . LBS.concat - $ [ "user_pref(", encode k, ", ", encode v, ");\n"] - - --- |Apply a function on an automatically generated default profile, and --- prepare the result. The FirefoxProfile passed to the handler function is --- the default profile used by sessions when Nothing is specified -prepareTempProfile :: MonadIO m => - (FirefoxProfile -> FirefoxProfile) - -> m PreparedFirefoxProfile -prepareTempProfile f = liftM f tempProfile >>= prepareProfile - --- |Convenience function to load an existing Firefox profile from disk, apply --- a handler function, and then prepare the result for network transmission. -prepareLoadedProfile :: MonadIO m => - FilePath - -> (FirefoxProfile -> FirefoxProfile) - -> m PreparedFirefoxProfile -prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile - -defaultProfile :: FilePath -> FirefoxProfile -defaultProfile d = - FirefoxProfile d HS.empty - $ HM.fromList [("app.update.auto", PrefBool False) - ,("app.update.enabled", PrefBool False) - ,("browser.startup.page" , PrefInteger 0) - ,("browser.download.manager.showWhenStarting", PrefBool False) - ,("browser.EULA.override", PrefBool True) - ,("browser.EULA.3.accepted", PrefBool True) - ,("browser.link.open_external", PrefInteger 2) - ,("browser.link.open_newwindow", PrefInteger 2) - ,("browser.offline", PrefBool False) - ,("browser.safebrowsing.enabled", PrefBool False) - ,("browser.search.update", PrefBool False) - ,("browser.sessionstore.resume_from_crash", PrefBool False) - ,("browser.shell.checkDefaultBrowser", PrefBool False) - ,("browser.tabs.warnOnClose", PrefBool False) - ,("browser.tabs.warnOnOpen", PrefBool False) - ,("browser.startup.page", PrefInteger 0) - ,("browser.safebrowsing.malware.enabled", PrefBool False) - ,("startup.homepage_welcome_url", PrefString "about:blank") - ,("devtools.errorconsole.enabled", PrefBool True) - ,("focusmanager.testmode", PrefBool True) - ,("dom.disable_open_during_load", PrefBool False) - ,("extensions.autoDisableScopes" , PrefInteger 10) - ,("extensions.logging.enabled", PrefBool True) - ,("extensions.update.enabled", PrefBool False) - ,("extensions.update.notifyUser", PrefBool False) - ,("network.manage-offline-status", PrefBool False) - ,("network.http.max-connections-per-server", PrefInteger 10) - ,("network.http.phishy-userpass-length", PrefInteger 255) - ,("offline-apps.allow_by_default", PrefBool True) - ,("prompts.tab_modal.enabled", PrefBool False) - ,("security.fileuri.origin_policy", PrefInteger 3) - ,("security.fileuri.strict_origin_policy", PrefBool False) - ,("security.warn_entering_secure", PrefBool False) - ,("security.warn_submit_insecure", PrefBool False) - ,("security.warn_entering_secure.show_once", PrefBool False) - ,("security.warn_entering_weak", PrefBool False) - ,("security.warn_entering_weak.show_once", PrefBool False) - ,("security.warn_leaving_secure", PrefBool False) - ,("security.warn_leaving_secure.show_once", PrefBool False) - ,("security.warn_submit_insecure", PrefBool False) - ,("security.warn_viewing_mixed", PrefBool False) - ,("security.warn_viewing_mixed.show_once", PrefBool False) - ,("signon.rememberSignons", PrefBool False) - ,("toolkit.networkmanager.disable", PrefBool True) - ,("toolkit.telemetry.enabled", PrefBool False) - ,("toolkit.telemetry.prompted", PrefInteger 2) - ,("toolkit.telemetry.rejected", PrefBool True) - ,("javascript.options.showInConsole", PrefBool True) - ,("browser.dom.window.dump.enabled", PrefBool True) - ,("webdriver_accept_untrusted_certs", PrefBool True) - ,("webdriver_enable_native_events", native_events) - ,("webdriver_assume_untrusted_issuer", PrefBool True) - ,("dom.max_script_run_time", PrefInteger 30) - ] - where -#ifdef darwin_HOST_OS - native_events = PrefBool False -#else - native_events = PrefBool True -#endif - -mkTemp :: IO FilePath -mkTemp = do - d <- getTemporaryDirectory - createTempDirectory d "" - --- firefox prefs.js parser - -prefsParser = many prefLine - -prefLine = do - padSpaces $ string "user_pref(" - k <- prefKey - padSpaces $ char ',' - v <- prefVal - padSpaces $ string ");" - endOfLine - return (k,v) - where - spaces = AP.takeWhile isSpace - padSpaces p = spaces >> p >> spaces - -prefKey = str -prefVal = boolVal <|> stringVal <|> intVal <|> doubleVal - where - boolVal = boolTrue <|> boolFalse - boolTrue = string "true" >> return (PrefBool True) - boolFalse = string "false" >> return (PrefBool False) - stringVal = PrefString <$> str - intVal = PrefInteger <$> signed decimal - doubleVal = PrefDouble <$> double - -str = char '"' >> AP.takeWhile (not . (=='"')) <* char '"' diff --git a/Test/WebDriver/Internal.hs b/Test/WebDriver/Internal.hs deleted file mode 100644 --- a/Test/WebDriver/Internal.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} -module Test.WebDriver.Internal - ( mkWDUri, mkRequest - , handleHTTPErr, handleJSONErr, handleHTTPResp - ) where - -import Test.WebDriver.Types -import Test.WebDriver.Types.Internal -import Test.WebDriver.JSON - -import Network.HTTP (simpleHTTP, Request(..), Response(..), RequestMethod(..)) -import Network.HTTP.Headers (findHeader, Header(..), HeaderName(..)) -import Network.URI -import Data.Aeson -import Data.Aeson.Types (emptyArray) - -import Data.Text (Text) -import qualified Data.Text as T -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.Vector as V - -import Control.Applicative -import Control.Exception.Lifted (throwIO) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State.Class (get) -import Data.List (isInfixOf) -import Data.Maybe (fromJust) -- used with relativeTo -import Data.String (fromString) - -mkWDUri :: String -> WD URI --todo: remove String :( -mkWDUri path = do - WDSession{wdHost = host, - wdPort = port - } <- get - let urlStr = "http://" ++ host ++ ":" ++ show port - relPath = "/wd/hub" ++ path - mBaseURI = parseAbsoluteURI urlStr - mRelURI = parseRelativeReference relPath - case (mBaseURI, mRelURI) of - (Nothing, _) -> throwIO $ InvalidURL urlStr - (_, Nothing) -> throwIO $ InvalidURL relPath - (Just baseURI, Just relURI) -> return . fromJust $ relURI `relativeTo` baseURI - -mkRequest :: ToJSON a => [Header] -> RequestMethod -> Text -> a -> WD (Response ByteString) -mkRequest headers method path args = do - uri <- mkWDUri (T.unpack path) - let body = case toJSON args of - Array v | V.null v -> "" --an ugly corner case to allow empty requests - other -> encode other - req = Request { rqURI = uri --todo: normalization of headers - , rqMethod = method - , rqBody = body - , rqHeaders = headers ++ [ Header HdrAccept - "application/json;charset=UTF-8" - , Header HdrContentType - "application/json;charset=UTF-8" - , Header HdrContentLength - . show . BS.length $ body - ] - } --- liftIO . print $ req - liftIO (simpleHTTP req) >>= either (throwIO . HTTPConnError) return - - -handleHTTPErr :: Response ByteString -> WD () -handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = - case code of - (4,_,_) -> err UnknownCommand - (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,2) -> return () - _ -> err (HTTPStatusUnknown code) - where - err errType = throwIO $ errType reason - -handleHTTPResp :: FromJSON a => Response ByteString -> WD a -handleHTTPResp resp@Response{rspBody = body, rspCode = code} = - case code of - (2,0,4) -> returnEmptyArray - (3,0,2) -> fromJSON' =<< maybe statusErr (return . String . fromString) - (findHeader HdrLocation resp) - where - statusErr = throwIO . HTTPStatusUnknown code - $ (BS.unpack body) - other - | BS.null body -> returnEmptyArray - | otherwise -> fromJSON' . rspVal =<< parseJSON' body - where - returnEmptyArray = fromJSON' emptyArray - -handleJSONErr :: WDResponse -> WD () -handleJSONErr WDResponse{rspStatus = 0} = return () -handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do - sess <- get - 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 - 34 -> e MoveTargetOutOfBounds - 51 -> e InvalidXPathSelector - 52 -> e InvalidXPathSelectorReturnType - 405 -> e MethodNotAllowed - _ -> e UnknownError diff --git a/Test/WebDriver/JSON.hs b/Test/WebDriver/JSON.hs deleted file mode 100644 --- a/Test/WebDriver/JSON.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- |A collection of convenience functions for using and parsing JSON values --- within 'WD'. All monadic parse errors are converted to asynchronous --- 'BadJSON' exceptions. -module Test.WebDriver.JSON - ( -- * Access a JSON object key - (!:) - -- * Conversion from JSON within WD - -- |Apostrophes are used to disambiguate these functions - -- from their "Data.Aeson" counterparts. - , parseJSON', fromJSON' - -- * Tuple functions - -- |Convenience functions for working with tuples. - - -- ** JSON object constructors - , single, pair, triple - -- ** Extracting JSON objects into tuples - , parsePair, parseTriple - -- * Conversion from parser results to WD - -- |These functions are used to implement the other functions - -- in this module, and could be used to implement other JSON - -- convenience functions - , apResultToWD, aesonResultToWD - ) where -import Test.WebDriver.Types - -import Data.Aeson as Aeson -import Data.Aeson.Types -import Data.Text (Text) -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Attoparsec.ByteString.Lazy (Result(..)) -import qualified Data.Attoparsec.ByteString.Lazy as AP - -import Control.Applicative -import Control.Exception.Lifted -import Data.String - --- |Construct a singleton JSON 'object' from a key and value. -single :: ToJSON a => Text -> a -> Value -single a x = object [a .= x] - --- |Construct a 2-element JSON 'object' from a pair of keys and a pair of --- values. -pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value -pair (a,b) (x,y) = object [a .= x, b .= y] - --- |Construct a 3-element JSON 'object' from a triple of keys and a triple of --- values. -triple :: (ToJSON a, ToJSON b, ToJSON c) => - (Text,Text,Text) -> (a,b,c) -> Value -triple (a,b,c) (x,y,z) = object [a .= x, b.= y, c .= z] - - --- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an --- instance of 'FromJSON'.. -parseJSON' :: FromJSON a => ByteString -> WD a -parseJSON' = apResultToWD . AP.parse json - --- |Convert a JSON 'Value' to an instance of 'FromJSON'. -fromJSON' :: FromJSON a => Value -> WD a -fromJSON' = aesonResultToWD . fromJSON - - - --- |This operator is a wrapper over Aeson's '.:' operator. -(!:) :: FromJSON a => Object -> Text -> WD a -o !: k = aesonResultToWD $ parse (.: k) o - - --- |Parse a JSON 'Object' as a pair. The first two string arguments specify the --- keys to extract from the object. The fourth string is the name of the --- calling function, for better error reporting. -parsePair :: (FromJSON a, FromJSON b) => - String -> String -> String -> Value -> WD (a, b) -parsePair a b funcName v = - case v of - Object o -> (,) <$> o !: fromString a <*> o !: fromString b - _ -> throwIO . BadJSON $ funcName ++ - ": cannot parse non-object JSON response as a (" ++ a - ++ ", " ++ b ++ ") pair" ++ ")" - - --- |Parse a JSON Object as a triple. The first three string arguments --- specify the keys to extract from the object. The fourth string is the name --- of the calling function, for better error reporting. -parseTriple :: (FromJSON a, FromJSON b, FromJSON c) => - String -> String -> String -> String -> Value -> WD (a, b, c) -parseTriple a b c funcName v = - case v of - Object o -> (,,) <$> o !: fromString a - <*> o !: fromString b - <*> o !: fromString c - _ -> throwIO . BadJSON $ funcName ++ - ": cannot parse non-object JSON response as a (" ++ a - ++ ", " ++ b ++ ", " ++ c ++ ") pair" - - - --- |Convert an attoparsec parser result to 'WD'. -apResultToWD :: FromJSON a => AP.Result Value -> WD a -apResultToWD p = case p of - Done _ res -> fromJSON' res - Fail _ _ err -> throwIO $ BadJSON err - --- |Convert an Aeson parser result to 'WD'. -aesonResultToWD :: Aeson.Result a -> WD a -aesonResultToWD r = case r of - Success val -> return val - Error err -> throwIO $ BadJSON err diff --git a/Test/WebDriver/Types.hs b/Test/WebDriver/Types.hs deleted file mode 100644 --- a/Test/WebDriver/Types.hs +++ /dev/null @@ -1,739 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, - TemplateHaskell, OverloadedStrings, ExistentialQuantification, - MultiParamTypeClasses, TypeFamilies, NoMonoLocalBinds - #-} -{-# OPTIONS_HADDOCK not-home #-} -module Test.WebDriver.Types - ( -- * WebDriver sessions - WD(..), WDSession(..), defaultSession, SessionId(..) - -- * Capabilities and configuration - , Capabilities(..), defaultCaps, allCaps - , Platform(..), ProxyType(..) - -- ** Browser-specific configuration - , Browser(..), - -- ** Default settings for browsers - firefox, chrome, ie, opera, iPhone, iPad, android - , FFLogPref - -- * WebDriver objects and command-specific types - , Element(..) - , WindowHandle(..), currentWindow - , Selector(..) - , JSArg(..) - , FrameSelector(..) - , Cookie(..), mkCookie - , Orientation(..) - , MouseButton(..) - , WebStorageType(..) - -- * Exceptions - , InvalidURL(..), NoSessionId(..), BadJSON(..) - , HTTPStatusUnknown(..), HTTPConnError(..) - , UnknownCommand(..), ServerError(..) - , FailedCommand(..), FailedCommandType(..) - , FailedCommandInfo(..), StackFrame(..) - , mkFailedCommandInfo, failedCommand - ) where - -import Test.WebDriver.Firefox.Profile -import Test.WebDriver.Chrome.Extension - -import Data.Aeson -import Data.Aeson.TH -import Data.Aeson.Types -import Network.Stream (ConnError) - - -import Data.Text as Text (toLower, toUpper, unpack) -import Data.Text (Text) -import Data.ByteString (ByteString) - -import Control.Exception.Lifted -import Data.Typeable -import Control.Applicative -import Control.Monad.State.Strict -import Control.Monad.Base -import Control.Monad.Trans.Control -import Data.Maybe -import Data.Word -import Data.String -import Text.Show -import Data.Default -import qualified Data.Char as C - - -{- |A monadic interface to the WebDriver server. This monad is a simple, strict -layer over 'IO', threading session information between sequential commands --} -newtype WD a = WD (StateT WDSession IO a) - deriving (Functor, Monad, MonadState WDSession, MonadIO - ,Applicative) - -instance MonadBase IO WD where - liftBase = WD . liftBase - -instance MonadBaseControl IO WD where - data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a} - - liftBaseWith f = WD $ - liftBaseWith $ \runInBase -> - f (\(WD sT) -> liftM StWD . runInBase $ sT) - - restoreM = WD . restoreM . unStWD - -{- |An opaque identifier for a WebDriver session. These handles are produced by -the server on session creation, and act to identify a session in progress. -} -newtype SessionId = SessionId Text - deriving (Eq, Ord, Show, Read, - FromJSON, ToJSON) - - -{- |An opaque identifier for a browser window -} -newtype WindowHandle = WindowHandle Text - deriving (Eq, Ord, Show, Read, - FromJSON, ToJSON) -{- |An opaque identifier for a web page element. -} -newtype Element = Element Text - deriving (Eq, Ord, Show, Read) - --- |A special 'WindowHandle' that always refers to the currently focused window. -currentWindow :: WindowHandle -currentWindow = WindowHandle "current" - --- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame' -data FrameSelector = WithIndex Integer - -- |focus on a frame by name or ID - | WithName Text - -- |focus on a frame Element - | WithElement Element - -- |focus on the first frame, or the main document - -- if iframes are used. - | DefaultFrame - deriving (Eq, Show, Read) - -{- |Information about a WebDriver session. This structure is passed -implicitly through all 'WD' computations, and is also used to configure the 'WD' -monad before execution. -} -data WDSession = WDSession { - -- |Host name of the WebDriver server for this - -- session - wdHost :: String - -- |Port number of the server - , wdPort :: Word16 - -- |An opaque reference identifying the session to - -- use with 'WD' commands. - -- A value of Nothing indicates that a session - -- hasn't been created yet. - -- Sessions can be created within 'WD' via the - -- 'Test.WebDriver.createSession', or created - -- and closed automatically with - -- 'Test.WebDriver.runSession' - , wdSessId :: Maybe SessionId - } deriving (Eq, Show) - -instance Default WDSession where - def = WDSession { wdHost = "127.0.0.1" - , wdPort = 4444 - , wdSessId = Nothing - } - -{- |A default session connects to localhost on port 4444, and hasn't been -created yet. This value is the same as 'def' but with a more specific type. -} -defaultSession :: WDSession -defaultSession = def - - -{- |A structure describing the capabilities of a session. This record -serves dual roles. - -* It's used to specify the desired capabilities for a session before -it's created. In this usage, fields that are set to Nothing indicate -that we have no preference for that capability. - -* When received from the server , it's used to -describe the actual capabilities given to us by the WebDriver -server. Here a value of Nothing indicates that the server doesn't -support the capability. Thus, for Maybe Bool fields, both Nothing and -Just False indicate a lack of support for the desired capability. --} -data Capabilities = Capabilities { -- |Browser choice and browser specific - -- settings. - browser :: Browser - -- |Browser version to use. - , version :: Maybe String - -- |Platform on which the browser should/will - -- run. - , platform :: Platform - -- |Proxy configuration. - , proxy :: ProxyType - , javascriptEnabled :: Maybe Bool - , takesScreenshot :: Maybe Bool - , handlesAlerts :: Maybe Bool - , databaseEnabled :: Maybe Bool - , locationContextEnabled :: Maybe Bool - , applicationCacheEnabled :: Maybe Bool - , browserConnectionEnabled :: Maybe Bool - , cssSelectorsEnabled :: Maybe Bool - , webStorageEnabled :: Maybe Bool - , rotatable :: Maybe Bool - , acceptSSLCerts :: Maybe Bool - , nativeEvents :: Maybe Bool - } deriving (Eq, Show) - -instance Default Capabilities where - def = Capabilities { browser = firefox - , version = Nothing - , platform = Any - , javascriptEnabled = Nothing - , takesScreenshot = Nothing - , handlesAlerts = Nothing - , databaseEnabled = Nothing - , locationContextEnabled = Nothing - , applicationCacheEnabled = Nothing - , browserConnectionEnabled = Nothing - , cssSelectorsEnabled = Nothing - , webStorageEnabled = Nothing - , rotatable = Nothing - , acceptSSLCerts = Nothing - , nativeEvents = Nothing - , proxy = UseSystemSettings - } - --- |Default capabilities. This is the same as the 'Default' instance, but with --- less polymorphism. By default, we use 'firefox' of an unspecified 'version' --- with default system-wide proxy settings on whatever 'platform' is available. --- All Maybe Bool capabilities are set to Nothing (no preference). -defaultCaps :: Capabilities -defaultCaps = def - --- |Same as 'defaultCaps', but with all Maybe Bool capabilities set to --- Just True. -allCaps :: Capabilities -allCaps = defaultCaps { javascriptEnabled = Just True - , takesScreenshot = Just True - , handlesAlerts = Just True - , databaseEnabled = Just True - , locationContextEnabled = Just True - , applicationCacheEnabled = Just True - , browserConnectionEnabled = Just True - , cssSelectorsEnabled = Just True - , webStorageEnabled = Just True - , rotatable = Just True - , acceptSSLCerts = Just True - , nativeEvents = Just True - } - - --- |Browser setting and browser-specific capabilities. -data Browser = Firefox { -- |The firefox profile to use. If Nothing, - -- a default temporary profile is automatically created - -- and used. - ffProfile :: Maybe PreparedFirefoxProfile - -- |Firefox logging preference - , ffLogPref :: Maybe FFLogPref - -- |Path to Firefox binary. If Nothing, use a sensible - -- system-based default. - , ffBinary :: Maybe FilePath - } - | Chrome { -- |Version of the Chrome Webdriver server server to use. - -- for more information on chromedriver see - -- - chromeDriverVersion :: Maybe String - -- |Path to Chrome binary. If Nothing, use a sensible - -- system-based default. - , chromeBinary :: Maybe FilePath - -- |A list of command-line options to pass to the - -- Chrome binary. - , chromeOptions :: [String] - -- |A list of extensions to use. - , chromeExtensions :: [ChromeExtension] - } - | IE { ignoreProtectedModeSettings :: Bool - --, useLegacyInternalServer :: Bool - } - | Opera -- ^ (Opera-specific configuration coming soon!) - | HTMLUnit - | IPhone - | IPad - | Android - deriving (Eq, Show) - --- |Default Firefox settings. All fields are set to Nothing. -firefox :: Browser -firefox = Firefox Nothing Nothing Nothing - --- |Default Chrome settings. All Maybe fields are set to Nothing, no options are --- specified, and no extensions are used. -chrome :: Browser -chrome = Chrome Nothing Nothing [] [] - --- |Default IE settings. 'ignoreProtectedModeSettings' is set to True. -ie :: Browser -ie = IE True - -opera :: Browser -opera = Opera - ---safari :: Browser ---safari = Safari - -htmlUnit :: Browser -htmlUnit = HTMLUnit - -iPhone :: Browser -iPhone = IPhone - -iPad :: Browser -iPad = IPad - -android :: Browser -android = Android - - --- |Represents platform options supported by WebDriver. The value Any represents --- no preference. -data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any - deriving (Eq, Show, Ord, Bounded, Enum) - --- |Available settings for the proxy 'Capabilities' field -data ProxyType = NoProxy - | UseSystemSettings - | AutoDetect - -- |Use a proxy auto-config file specified by URL - | PAC { autoConfigUrl :: String } - -- |Manually specify proxy hosts as hostname:port strings. - -- Note that behavior is undefined for empty strings. - | Manual { ftpProxy :: String - , sslProxy :: String - , httpProxy :: String - } - deriving (Eq, Show) - - --- |For 'Firefox' sessions; indicates Firefox's log level -data FFLogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig - | LogFine | LogFiner | LogFinest | LogAll - deriving (Eq, Show, Ord, Bounded, Enum) - - -instance Exception InvalidURL --- |An invalid URL was given -newtype InvalidURL = InvalidURL String - deriving (Eq, Show, Typeable) - -instance Exception NoSessionId --- |A command requiring a session ID was attempted when no session ID was --- available. -newtype NoSessionId = NoSessionId String - deriving (Eq, Show, Typeable) - -instance Exception BadJSON --- |An error occured when parsing a JSON value. -newtype BadJSON = BadJSON String - deriving (Eq, Show, Typeable) - -instance Exception HTTPStatusUnknown --- |An unexpected HTTP status was sent by the server. -data HTTPStatusUnknown = HTTPStatusUnknown (Int, Int, Int) String - deriving (Eq, Show, Typeable) - -instance Exception HTTPConnError --- |HTTP connection errors. -newtype HTTPConnError = HTTPConnError ConnError - deriving (Eq, Show, Typeable) - -instance Exception UnknownCommand --- |A command was sent to the WebDriver server that it didn't recognize. -newtype UnknownCommand = UnknownCommand String - deriving (Eq, Show, Typeable) - -instance Exception ServerError --- |A server-side exception occured -newtype ServerError = ServerError String - deriving (Eq, Show, Typeable) - -instance Exception FailedCommand --- |This exception encapsulates a broad variety of exceptions that can --- occur when a command fails. -data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo - deriving (Eq, Show, Typeable) - --- |The type of failed command exception that occured. -data FailedCommandType = NoSuchElement - | NoSuchFrame - | UnknownFrame - | StaleElementReference - | ElementNotVisible - | InvalidElementState - | UnknownError - | ElementIsNotSelectable - | JavascriptError - | XPathLookupError - | Timeout - | NoSuchWindow - | InvalidCookieDomain - | UnableToSetCookie - | UnexpectedAlertOpen - | NoAlertOpen - | ScriptTimeout - | InvalidElementCoordinates - | IMENotAvailable - | IMEEngineActivationFailed - | InvalidSelector - | MoveTargetOutOfBounds - | InvalidXPathSelector - | InvalidXPathSelectorReturnType - | MethodNotAllowed - deriving (Eq, Ord, Enum, Bounded, Show) - --- |Detailed information about the failed command provided by the server. -data FailedCommandInfo = FailedCommandInfo { -- |The error message. - errMsg :: String - -- |The session associated with - -- the exception. - , errSess :: WDSession - -- |A screen shot of the focused window - -- when the exception occured, - -- if provided. - , errScreen :: Maybe ByteString - -- |The "class" in which the exception - -- was raised, if provided. - , errClass :: Maybe String - -- |A stack trace of the exception. - , errStack :: [StackFrame] - } - deriving (Eq) - - --- |Constructs a FailedCommandInfo from only an error message. -mkFailedCommandInfo :: String -> WD FailedCommandInfo -mkFailedCommandInfo m = do - sess <- get - return $ FailedCommandInfo {errMsg = m , errSess = sess , errScreen = Nothing - , errClass = Nothing , errStack = [] } - --- |Convenience function to throw a 'FailedCommand' locally with no server-side --- info present. -failedCommand :: FailedCommandType -> String -> WD a -failedCommand t m = throwIO . FailedCommand t =<< mkFailedCommandInfo m - --- |An individual stack frame from the stack trace provided by the server --- during a FailedCommand. -data StackFrame = StackFrame { sfFileName :: String - , sfClassName :: String - , sfMethodName :: String - , sfLineNumber :: Word - } - deriving (Eq) - --- |Cookies are delicious delicacies. When sending cookies to the server, a value --- of Nothing indicates that the server should use a default value. When receiving --- cookies from the server, a value of Nothing indicates that the server is unable --- to specify the value. -data Cookie = Cookie { cookName :: Text - , cookValue :: Text -- ^ - , cookPath :: Maybe Text -- ^path of this cookie. - -- if Nothing, defaults to / - , cookDomain :: Maybe Text -- ^domain of this cookie. - -- if Nothing, the current pages - -- domain is used - , cookSecure :: Maybe Bool -- ^Is this cookie secure? - , cookExpiry :: Maybe Integer -- ^Expiry date expressed as - -- seconds since the Unix epoch - -- Nothing indicates that the - -- cookie never expires - } deriving (Eq, Show) - --- |Creates a Cookie with only a name and value specified. All other --- fields are set to Nothing, which tells the server to use default values. -mkCookie :: Text -> Text -> Cookie -mkCookie name value = Cookie { cookName = name, cookValue = value, - cookPath = Nothing, cookDomain = Nothing, - cookSecure = Nothing, cookExpiry = Nothing - } - --- |Specifies element(s) within a DOM tree using various selection methods. -data Selector = ById Text - | ByName Text - | ByClass Text -- ^ (Note: multiple classes are not - -- allowed. For more control, use 'ByCSS') - | ByTag Text - | ByLinkText Text - | ByPartialLinkText Text - | ByCSS Text - | ByXPath Text - deriving (Eq, Show, Ord) - --- |An existential wrapper for any 'ToJSON' instance. This allows us to pass --- parameters of many different types to Javascript code. -data JSArg = forall a. ToJSON a => JSArg a - --- |A screen orientation -data Orientation = Landscape | Portrait - deriving (Eq, Show, Ord, Bounded, Enum) - --- |A mouse button -data MouseButton = LeftButton | MiddleButton | RightButton - deriving (Eq, Show, Ord, Bounded, Enum) - - --- |An HTML 5 storage type -data WebStorageType = LocalStorage | SessionStorage - deriving (Eq, Show, Ord, Bounded, Enum) - -instance Show FailedCommandInfo where --todo: pretty print - 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 "" . errClass $ i - - sess = showString sessId . showString " at " - . showString host . showChar ':' . shows port - where - WDSession {wdHost = host, wdPort = port, wdSessId = msid } = errSess i - sessId = case msid of - Just (SessionId sid) -> unpack sid - Nothing -> "" - -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 Element where - parseJSON (Object o) = Element <$> o .: "ELEMENT" - parseJSON v = typeMismatch "Element" v - -instance ToJSON Element where - toJSON (Element e) = object ["ELEMENT" .= e] - - -instance ToJSON Capabilities where - toJSON c = object $ [ "browserName" .= browser' - , f version "version" - , f platform "platform" - , f proxy "proxy" - , f javascriptEnabled "javascriptEnabled" - , f takesScreenshot "takesScreenshot" - , f handlesAlerts "handlesAlerts" - , f databaseEnabled "databaseEnabled" - , f locationContextEnabled "locationContextEnabled" - , f applicationCacheEnabled "applicationCacheEnabled" - , f browserConnectionEnabled "browserConnectionEnabled" - , f cssSelectorsEnabled "cssSelectorsEnabled" - , f webStorageEnabled "webStorableEnabled" - , f rotatable "rotatable" - , f acceptSSLCerts "acceptSslCerts" - , f nativeEvents "nativeEvents" - ] - ++ browserInfo - where - browser' = browser c - browserInfo = case browser' of - Firefox {ffProfile = prof, ffLogPref = pref, ffBinary = bin } - -> ["firefox_profile" .= prof - ,"loggingPrefs" .= pref - ,"firefox_binary" .= bin - ] - Chrome {chromeDriverVersion = v, chromeBinary = b, - chromeOptions = o, chromeExtensions = e} - -> ["chrome.chromedriverVersion" .= v - ,"chrome.binary" .= b - ,"chrome.switches" .= o - ,"chrome.extensions" .= e - ] - IE {ignoreProtectedModeSettings = i{-, useLegacyInternalServer = u-}} - -> ["IgnoreProtectedModeSettings" .= i - --,"useLegacyInternalServer" .= u - ] - _ -> [] - f :: ToJSON a => (Capabilities -> a) -> Text -> Pair - f field key = key .= field c - -instance FromJSON Capabilities where - parseJSON (Object o) = Capabilities <$> req "browserName" - <*> opt "version" Nothing - <*> req "platform" - <*> opt "proxy" NoProxy - <*> b "javascriptEnabled" - <*> b "takesScreenshot" - <*> b "handlesAlerts" - <*> b "databaseEnabled" - <*> b "locationContextEnabled" - <*> b "applicationCacheEnabled" - <*> b "browserConnectionEnabled" - <*> b "cssSelectorEnabled" - <*> b "webStorageEnabled" - <*> b "rotatable" - <*> b "acceptSslCerts" - <*> b "nativeEvents" - where req :: FromJSON a => Text -> Parser a - req = (o .:) -- required field - opt :: FromJSON a => Text -> a -> Parser a - opt k d = o .:? k .!= d -- optional field - b :: Text -> Parser (Maybe Bool) - b k = opt k Nothing -- Maybe Bool field - parseJSON v = typeMismatch "Capabilities" v - -instance FromJSON FailedCommandInfo where - parseJSON (Object o) = - FailedCommandInfo <$> (req "message" >>= maybe (return "") return) - <*> pure undefined - <*> opt "screen" Nothing - <*> opt "class" Nothing - <*> opt "stackTrace" [] - where --req :: FromJSON a => Text -> Parser a - req = (o .:) --required key - --opt :: FromJSON a => Text -> a -> Parser a - opt k d = o .:? k .!= d --optional key - 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 .:) -- all keys are required - reqStr :: Text -> Parser String - reqStr k = req k >>= maybe (return "") return - parseJSON v = typeMismatch "StackFrame" v - -$( deriveToJSON (map C.toLower . drop 4) ''Cookie ) - -$( deriveJSON (map C.toUpper . drop 3) ''FFLogPref ) - -instance FromJSON Cookie where - parseJSON (Object o) = Cookie <$> req "name" - <*> req "value" - <*> opt "path" Nothing - <*> opt "domain" Nothing - <*> opt "secure" Nothing - <*> opt "expiry" Nothing - 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 "Cookie" v - - -instance ToJSON Browser where - toJSON Firefox {} = String "firefox" - toJSON b = String . f . toLower . fromString . show $ b - where f "ie" = "internet explorer" - f x = x - -instance FromJSON Browser where - parseJSON (String jStr) = case toLower jStr of - "firefox" -> return firefox - "chrome" -> return chrome - "internet explorer" -> return ie - "opera" -> return opera - -- "safari" -> return safari - "iphone" -> return iPhone - "ipad" -> return iPad - "android" -> return android - "htmlunit" -> return htmlUnit - err -> fail $ "Invalid Browser string " ++ show err - parseJSON v = typeMismatch "Browser" v - -instance ToJSON Platform where - toJSON = String . toUpper . fromString . show - -instance FromJSON Platform where - parseJSON (String jStr) = case toLower jStr of - "windows" -> return Windows - "xp" -> return XP - "vista" -> return Vista - "mac" -> return Mac - "linux" -> return Linux - "unix" -> return Unix - "any" -> return Any - err -> fail $ "Invalid Platform string " ++ show err - parseJSON v = typeMismatch "Platform" v - -instance ToJSON Orientation where - toJSON = String . toUpper . fromString . show - -instance FromJSON Orientation where - parseJSON (String jStr) = case toLower jStr of - "landscape" -> return Landscape - "portrait" -> return Portrait - err -> fail $ "Invalid Orientation string " ++ show err - parseJSON v = typeMismatch "Orientation" v - -instance ToJSON MouseButton where - toJSON = String . toUpper . fromString . show - -instance FromJSON MouseButton where - parseJSON (String jStr) = case toLower jStr of - "left" -> return LeftButton - "middle" -> return MiddleButton - "right" -> return RightButton - err -> fail $ "Invalid MouseButton string " ++ show err - parseJSON v = typeMismatch "MouseButton" v - - -instance FromJSON ProxyType where - parseJSON (Object obj) = do - let f :: FromJSON a => Text -> Parser a - f = (obj .:) - pTyp <- f "proxyType" - case toLower pTyp of - "direct" -> return NoProxy - "system" -> return UseSystemSettings - "pac" -> PAC <$> f "autoConfigUrl" - "manual" -> Manual <$> f "ftpProxy" - <*> f "sslProxy" - <*> f "httpProxy" - _ -> fail $ "Invalid ProxyType " ++ show pTyp - parseJSON v = typeMismatch "ProxyType" v - -instance ToJSON ProxyType where - toJSON pt = object $ case pt of - NoProxy -> - ["proxyType" .= ("DIRECT" :: String)] - UseSystemSettings -> - ["proxyType" .= ("SYSTEM" :: String)] - AutoDetect -> - ["proxyType" .= ("AUTODETECT" :: String)] - PAC{autoConfigUrl = url} -> - ["proxyType" .= ("PAC" :: String) - ,"autoConfigUrl" .= url - ] - Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} -> - ["proxyType" .= ("MANUAL" :: String) - ,"ftpProxy" .= ftp - ,"sslProxy" .= ssl - ,"httpProxy" .= http - ] - -instance ToJSON Selector where - toJSON s = case s of - ById t -> selector "id" t - ByName t -> selector "name" t - ByClass t -> selector "class name" t - ByTag t -> selector "tag name" t - ByLinkText t -> selector "link text" t - ByPartialLinkText t -> selector "partial link text" t - ByCSS t -> selector "css selector" t - ByXPath t -> selector "xpath" t - where - selector :: Text -> Text -> Value - selector sn t = object ["using" .= sn, "value" .= t] - -instance ToJSON JSArg where - toJSON (JSArg a) = toJSON a - -instance ToJSON FrameSelector where - toJSON s = case s of - WithIndex i -> toJSON i - WithName n -> toJSON n - WithElement e -> toJSON e - DefaultFrame -> Null diff --git a/Test/WebDriver/Types/Internal.hs b/Test/WebDriver/Types/Internal.hs deleted file mode 100644 --- a/Test/WebDriver/Types/Internal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} -module Test.WebDriver.Types.Internal - ( WDResponse(..) - ) where - -import Test.WebDriver.Types - -import Data.Aeson -import Data.Aeson.Types - -import Control.Applicative -import Data.Word - - -data WDResponse = WDResponse { rspSessId :: Maybe SessionId - , rspStatus :: Word8 - , rspVal :: Value - } - deriving (Eq, Show) - -instance FromJSON WDResponse where - parseJSON (Object o) = WDResponse <$> req "sessionId" - <*> req "status" - <*> opt "value" Null - where req = (o .:) - opt k d = o .: k .!= d - parseJSON v = typeMismatch "WDResponse" v diff --git a/src/Test/WebDriver.hs b/src/Test/WebDriver.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver.hs @@ -0,0 +1,25 @@ +{-| +This module serves as the top-level interface to the Haskell WebDriver bindings, +providing most of the functionality you're likely to want. +-} +module Test.WebDriver + ( -- * WebDriver sessions + WD(..), WDSession(..), defaultSession, SessionId(..) + -- * Running WebDriver tests + , runWD, runSession, withSession, finallyClose, closeOnException + -- * Capabilities and configuration + , Capabilities(..), defaultCaps, allCaps + , Platform(..), ProxyType(..) + -- ** Browser-specific configuration + , Browser(..), LogPref(..) + , firefox, chrome, ie, opera, iPhone, iPad, android + -- * WebDriver commands + , module Test.WebDriver.Commands + -- * Exceptions + , module Test.WebDriver.Exceptions + ) where + +import Test.WebDriver.Types +import Test.WebDriver.Commands +import Test.WebDriver.Monad +import Test.WebDriver.Exceptions diff --git a/src/Test/WebDriver/Capabilities.hs b/src/Test/WebDriver/Capabilities.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards + #-} +module Test.WebDriver.Capabilities where + +import Test.WebDriver.Firefox.Profile +import Test.WebDriver.Chrome.Extension +import Test.WebDriver.JSON + +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) + +import Data.Text (Text, toLower, toUpper) +import Data.Default (Default(..)) +import Data.Word (Word16) +import Data.Maybe (fromMaybe, catMaybes) +import Data.String (fromString) + +import Control.Applicative +import Control.Exception.Lifted (throw) + +{- |A structure describing the capabilities of a session. This record +serves dual roles. + +* It's used to specify the desired capabilities for a session before +it's created. In this usage, fields that are set to Nothing indicate +that we have no preference for that capability. + +* When received from the server , it's used to +describe the actual capabilities given to us by the WebDriver +server. Here a value of Nothing indicates that the server doesn't +support the capability. Thus, for Maybe Bool fields, both Nothing and +Just False indicate a lack of support for the desired capability. +-} +data Capabilities = + Capabilities { -- |Browser choice and browser specific settings. + browser :: Browser + -- |Browser version to use. + , version :: Maybe String + -- |Platform on which the browser should run. + , platform :: Platform + -- |Proxy configuration settings. + , proxy :: ProxyType + -- |Whether the session supports executing JavaScript via + -- 'executeJS' and 'asyncJS'. + , javascriptEnabled :: Maybe Bool + -- |Whether the session supports taking screenshots of the + -- current page with the 'screenshot' command + , takesScreenshot :: Maybe Bool + -- |Whether the session can interact with modal popups, + -- such as window.alert and window.confirm via + -- 'acceptAlerts', 'dismissAlerts', etc. + , handlesAlerts :: Maybe Bool + -- |Whether the session can interact with database storage. + , databaseEnabled :: Maybe Bool + -- |Whether the session can set and query the browser's + -- location context with 'setLocation' and 'getLocation'. + , locationContextEnabled :: Maybe Bool + -- |Whether the session can interact with the application cache + -- . + , applicationCacheEnabled :: Maybe Bool + -- |Whether the session can query for the browser's + -- connectivity and disable it if desired + , browserConnectionEnabled :: Maybe Bool + -- |Whether the session supports CSS selectors when searching + -- for elements. + , cssSelectorsEnabled :: Maybe Bool + -- |Whether Web Storage ('getKey', 'setKey', etc) support is + -- enabled + , webStorageEnabled :: Maybe Bool + -- |Whether the session can rotate the current page's current + -- layout between 'Portrait' and 'Landscape' orientations. + , rotatable :: Maybe Bool + -- |Whether the session should accept all SSL certs by default + , acceptSSLCerts :: Maybe Bool + -- |Whether the session is capable of generating native OS + -- events when simulating user input. + , nativeEvents :: Maybe Bool + } deriving (Eq, Show) + +instance Default Capabilities where + def = Capabilities { browser = firefox + , version = Nothing + , platform = Any + , javascriptEnabled = Nothing + , takesScreenshot = Nothing + , handlesAlerts = Nothing + , databaseEnabled = Nothing + , locationContextEnabled = Nothing + , applicationCacheEnabled = Nothing + , browserConnectionEnabled = Nothing + , cssSelectorsEnabled = Nothing + , webStorageEnabled = Nothing + , rotatable = Nothing + , acceptSSLCerts = Nothing + , nativeEvents = Nothing + , proxy = UseSystemSettings + } + +-- |Default capabilities. This is the same as the 'Default' instance, but with +-- less polymorphism. By default, we use 'firefox' of an unspecified 'version' +-- with default system-wide proxy settings on whatever 'platform' is available. +-- All Maybe Bool capabilities are set to Nothing (no preference). +defaultCaps :: Capabilities +defaultCaps = def + +-- |Same as 'defaultCaps', but with all Maybe Bool capabilities set to +-- Just True. +allCaps :: Capabilities +allCaps = defaultCaps { javascriptEnabled = Just True + , takesScreenshot = Just True + , handlesAlerts = Just True + , databaseEnabled = Just True + , locationContextEnabled = Just True + , applicationCacheEnabled = Just True + , browserConnectionEnabled = Just True + , cssSelectorsEnabled = Just True + , webStorageEnabled = Just True + , rotatable = Just True + , acceptSSLCerts = Just True + , nativeEvents = Just True + } + + +instance ToJSON Capabilities where + toJSON Capabilities{..} = + object $ [ "browserName" .= browser + , "version" .= version + , "platform" .= platform + , "proxy" .= proxy + , "javascriptEnabled" .= javascriptEnabled + , "takesScreenshot" .= takesScreenshot + , "handlesAlerts" .= handlesAlerts + , "databaseEnabled" .= databaseEnabled + , "locationContextEnabled" .= locationContextEnabled + , "applicationCacheEnabled" .= applicationCacheEnabled + , "browserConnectionEnabled" .= browserConnectionEnabled + , "cssSelectorsEnabled" .= cssSelectorsEnabled + , "webStorageEnabled" .= webStorageEnabled + , "rotatable" .= rotatable + , "acceptSslCerts" .= acceptSSLCerts + , "nativeEvents" .= nativeEvents + ] ++ browserInfo + where + browserInfo = case browser of + Firefox {..} + -> ["firefox_profile" .= ffProfile + ,"loggingPrefs" .= object ["driver" .= ffLogPref] + ,"firefox_binary" .= ffBinary + ] + Chrome {..} + -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion + , opt "chrome.binary" chromeBinary + ] + ++ ["chrome.switches" .= chromeOptions + ,"chrome.extensions" .= chromeExtensions + ] + IE {..} + -> ["IgnoreProtectedModeSettings" .= ignoreProtectedModeSettings + --,"useLegacyInternalServer" .= u + ] + Opera{..} + -> catMaybes [ opt "opera.binary" operaBinary + , opt "opera.display" operaDisplay + , opt "opera.product" operaProduct + , opt "opera.launcher" operaLauncher + , opt "opera.host" operaHost + , opt "opera.logging.file" operaLogFile + ] + ++ ["opera.detatch" .= operaDetach + ,"opera.no_quit" .= operaDetach --backwards compatability + ,"opera.autostart" .= operaAutoStart + , "opera.idle" .= operaIdle + -- ,"opera.profile" .= operaProfile + ,"opera.port" .= fromMaybe (-1) operaPort + --note: consider replacing operaOptions with a list of options + ,"opera.arguments" .= operaOptions + ,"opera.logging.level" .= operaLogPref + ] + _ -> [] + + where + opt k = fmap (k .=) + + +instance FromJSON Capabilities where + parseJSON (Object o) = Capabilities <$> req "browserName" + <*> opt "version" Nothing + <*> req "platform" + <*> opt "proxy" NoProxy + <*> b "javascriptEnabled" + <*> b "takesScreenshot" + <*> b "handlesAlerts" + <*> b "databaseEnabled" + <*> b "locationContextEnabled" + <*> b "applicationCacheEnabled" + <*> b "browserConnectionEnabled" + <*> b "cssSelectorEnabled" + <*> b "webStorageEnabled" + <*> b "rotatable" + <*> b "acceptSslCerts" + <*> b "nativeEvents" + where req :: FromJSON a => Text -> Parser a + req = (o .:) -- required field + opt :: FromJSON a => Text -> a -> Parser a + opt k d = o .:? k .!= d -- optional field + b :: Text -> Parser (Maybe Bool) + b k = opt k Nothing -- Maybe Bool field + parseJSON v = typeMismatch "Capabilities" v + +-- |This constructor simultaneously specifies which browser the session will +-- use, while also providing browser-specific configuration. Default +-- configuration is provided for each browser by 'firefox', 'chrome', 'opera', +-- 'ie', etc. +-- +-- This library uses 'firefox' as its 'Default' browser configuration, when no +-- browser choice is specified. +data Browser = Firefox { -- |The firefox profile to use. If Nothing, + -- a default temporary profile is automatically created + -- and used. + ffProfile :: Maybe (PreparedProfile Firefox) + -- |Firefox logging preference + , ffLogPref :: LogPref + -- |Server-side path to Firefox binary. If Nothing, + -- use a sensible system-based default. + , ffBinary :: Maybe FilePath + } + | Chrome { -- |Version of the Chrome Webdriver server server to use + -- + -- for more information on chromedriver see + -- + chromeDriverVersion :: Maybe String + -- |Server-side path to Chrome binary. If Nothing, + -- use a sensible system-based default. + , chromeBinary :: Maybe FilePath + -- |A list of command-line options to pass to the + -- Chrome binary. + , chromeOptions :: [String] + -- |A list of extensions to use. + , chromeExtensions :: [ChromeExtension] + } + | IE { -- |Whether to skip the protected mode check. If set, tests + -- may become flaky, unresponsive, or browsers may hang. If + -- not set, and protected mode settings are not the same for + -- all zones, an exception will be thrown on driver + -- construction. + ignoreProtectedModeSettings :: Bool + --, useLegacyInternalServer :: Bool + } + | Opera { -- |Server-side path to the Opera binary + operaBinary :: Maybe FilePath + --, operaNoRestart :: Maybe Bool + -- |Which Opera product 'were using, e.g. "desktop", + -- "core" + , operaProduct :: Maybe String + -- |Whether the Opera instance should stay open after + -- we close the session. If False, closing the session + -- closes the browser. + , operaDetach :: Bool + -- |Whether to auto-start the Opera binary. If false, + -- OperaDriver will wait for a connection from the + -- browser. By default this is True. + , operaAutoStart :: Bool + -- |Whether to use Opera's alternative implicit wait + -- implementation. It will use an in-browser heuristic + -- to guess when a page has finished loading. This + -- feature is experimental, and disabled by default. + , operaIdle :: Bool + -- |(*nix only) which X display to use. + , operaDisplay :: Maybe Int + --, operaProfile :: Maybe (PreparedProfile Opera) + -- |Path to the launcher binary to use. The launcher + -- is a gateway between OperaDriver and the Opera + -- browser. If Nothing, OperaDriver will use the + -- launcher supplied with the package. + , operaLauncher :: Maybe FilePath + -- |The port we should use to connect to Opera. If Just 0 + -- , use a random port. If Nothing, use the default + -- Opera port. The default 'opera' constructor uses + -- Just 0, since Nothing is likely to cause "address + -- already in use" errors. + , operaPort :: Maybe Word16 + -- |The host Opera should connect to. Unless you're + -- starting Opera manually you won't need this. + , operaHost :: Maybe String + -- |Command-line arguments to pass to Opera. + , operaOptions :: String + -- |Where to send the log output. If Nothing, logging is + -- disabled. + , operaLogFile :: Maybe FilePath + -- |Log level preference. Defaults to 'LogInfo' + , operaLogPref :: LogPref + } + | HTMLUnit + | IPhone + | IPad + | Android + deriving (Eq, Show) + +instance Default Browser where + def = firefox + + +instance ToJSON Browser where + toJSON Firefox {} = String "firefox" + toJSON Chrome {} = String "chrome" + toJSON Opera {} = String "opera" + toJSON IE {} = String "internet explorer" + toJSON b = String . toLower . fromString . show $ b + +instance FromJSON Browser where + parseJSON (String jStr) = case toLower jStr of + "firefox" -> return firefox + "chrome" -> return chrome + "internet explorer" -> return ie + "opera" -> return opera + -- "safari" -> return safari + "iphone" -> return iPhone + "ipad" -> return iPad + "android" -> return android + "htmlunit" -> return htmlUnit + err -> fail $ "Invalid Browser string " ++ show err + parseJSON v = typeMismatch "Browser" v + + +-- |Default Firefox settings. All Maybe fields are set to Nothing. ffLogPref +-- is set to 'LogInfo'. +firefox :: Browser +firefox = Firefox Nothing def Nothing + +-- |Default Chrome settings. All Maybe fields are set to Nothing, no options are +-- specified, and no extensions are used. +chrome :: Browser +chrome = Chrome Nothing Nothing [] [] + +-- |Default IE settings. 'ignoreProtectedModeSettings' is set to True. +ie :: Browser +ie = IE True + +-- |Default Opera settings. See the 'Opera' constructor for more details on +-- individual defaults. +opera :: Browser +opera = Opera { operaBinary = Nothing + --, operaNoRestart = Nothing + , operaProduct = Nothing + , operaDetach = False + , operaAutoStart = True + , operaDisplay = Nothing + , operaIdle = False +-- , operaProfile = Nothing + , operaLauncher = Nothing + , operaHost = Nothing + , operaPort = Just 0 + , operaOptions = [] + , operaLogFile = Nothing + , operaLogPref = def + } + +--safari :: Browser +--safari = Safari + +htmlUnit :: Browser +htmlUnit = HTMLUnit + +iPhone :: Browser +iPhone = IPhone + +iPad :: Browser +iPad = IPad + +android :: Browser +android = Android + +-- |Represents platform options supported by WebDriver. The value Any represents +-- no preference. +data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any + deriving (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON Platform where + toJSON = String . toUpper . fromString . show + +instance FromJSON Platform where + parseJSON (String jStr) = case toLower jStr of + "windows" -> return Windows + "xp" -> return XP + "vista" -> return Vista + "mac" -> return Mac + "linux" -> return Linux + "unix" -> return Unix + "any" -> return Any + err -> fail $ "Invalid Platform string " ++ show err + parseJSON v = typeMismatch "Platform" v + +-- |Available settings for the proxy 'Capabilities' field +data ProxyType = NoProxy + | UseSystemSettings + | AutoDetect + -- |Use a proxy auto-config file specified by URL + | PAC { autoConfigUrl :: String } + -- |Manually specify proxy hosts as hostname:port strings. + -- Note that behavior is undefined for empty strings. + | Manual { ftpProxy :: String + , sslProxy :: String + , httpProxy :: String + } + deriving (Eq, Show) + +instance FromJSON ProxyType where + parseJSON (Object obj) = do + pTyp <- f "proxyType" + case toLower pTyp of + "direct" -> return NoProxy + "system" -> return UseSystemSettings + "pac" -> PAC <$> f "autoConfigUrl" + "manual" -> Manual <$> f "ftpProxy" + <*> f "sslProxy" + <*> f "httpProxy" + _ -> fail $ "Invalid ProxyType " ++ show pTyp + where + f :: FromJSON a => Text -> Parser a + f = (obj .:) + parseJSON v = typeMismatch "ProxyType" v + +instance ToJSON ProxyType where + toJSON pt = object $ case pt of + NoProxy -> + ["proxyType" .= ("DIRECT" :: String)] + UseSystemSettings -> + ["proxyType" .= ("SYSTEM" :: String)] + AutoDetect -> + ["proxyType" .= ("AUTODETECT" :: String)] + PAC{autoConfigUrl = url} -> + ["proxyType" .= ("PAC" :: String) + ,"autoConfigUrl" .= url + ] + Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} -> + ["proxyType" .= ("MANUAL" :: String) + ,"ftpProxy" .= ftp + ,"sslProxy" .= ssl + ,"httpProxy" .= http + ] + +-- |Indicates log verbosity. Used in 'Firefox' and 'Opera' configuration. +data LogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig + | LogFine | LogFiner | LogFinest | LogAll + deriving (Eq, Show, Ord, Bounded, Enum) + +instance Default LogPref where + def = LogInfo + +instance ToJSON LogPref where + toJSON p= String $ case p of + LogOff -> "OFF" + LogSevere -> "SEVERE" + LogWarning -> "WARNING" + LogInfo -> "INFO" + LogConfig -> "CONFIG" + LogFine -> "FINE" + LogFiner -> "FINER" + LogFinest -> "FINEST" + LogAll -> "ALL" + +instance FromJSON LogPref where + parseJSON (String s) = return $ case s of + "OFF" -> LogOff + "SEVERE" -> LogSevere + "WARNING" -> LogWarning + "INFO" -> LogInfo + "CONFIG" -> LogConfig + "FINE" -> LogFine + "FINER" -> LogFiner + "FINEST" -> LogFinest + "ALL" -> LogAll + _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s + parseJSON other = typeMismatch "LogPref" other diff --git a/src/Test/WebDriver/Chrome/Extension.hs b/src/Test/WebDriver/Chrome/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Chrome/Extension.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} +-- |Functions and types for working with Google Chrome extensions. +module Test.WebDriver.Chrome.Extension + ( ChromeExtension + , loadExtension + , loadRawExtension + ) where +import Data.ByteString as BS +import Data.ByteString.Base64 as B64 +import Data.Aeson +import Control.Applicative +import Control.Monad.Base + +-- |An opaque type representing a Google Chrome extension. Values of this type +-- are passed to the 'Test.Webdriver.chromeExtensions' field. +newtype ChromeExtension = ChromeExtension ByteString + deriving (Eq, Show, Read, ToJSON, FromJSON) + +-- |Load a .crx file as a 'ChromeExtension'. +loadExtension :: MonadBase IO m => FilePath -> m ChromeExtension +loadExtension path = liftBase $ loadRawExtension <$> BS.readFile path + +-- |Load raw .crx data as a 'ChromeExtension'. +loadRawExtension :: ByteString -> ChromeExtension +loadRawExtension = ChromeExtension . B64.encode diff --git a/src/Test/WebDriver/Classes.hs b/src/Test/WebDriver/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Classes.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, + GeneralizedNewtypeDeriving, StandaloneDeriving #-} +module Test.WebDriver.Classes + ( WebDriver(..), RequestMethod(..), + SessionState(..), modifySession + , WDSession(..), SessionId(..), defaultSession + , doSessCommand + -- * No Session Exception + , NoSessionId(..) + ) where + +--import Test.WebDriver.Internal +import Data.Aeson +import Network.HTTP (RequestMethod(..)) + +import qualified Data.Text as T +import Data.Text (Text) + +import Control.Monad.Trans.Control +import Control.Exception.Lifted (Exception, throwIO) +import Data.Typeable + +import Control.Monad.Trans.Maybe +import Control.Monad.List +import Control.Monad.Trans.Identity +import Control.Monad.Reader +import Control.Monad.Error +--import Control.Monad.Cont +import Control.Monad.Writer.Strict as SW +import Control.Monad.Writer.Lazy as LW +import Control.Monad.State.Strict as SS +import Control.Monad.State.Lazy as LS +import Control.Monad.RWS.Strict as SRWS +import Control.Monad.RWS.Lazy as LRWS + +import Data.Default +import Data.Word + + +-- |A class for monads that carry a WebDriver session with them. The +-- MonadBaseControl superclass is used for exception handling through +-- the lifted-base package. +class MonadBaseControl IO s => SessionState s where + getSession :: s WDSession + putSession :: WDSession -> s () + +-- |A class for monads that can handle wire protocol requests. This is the +-- operation underlying all of the high-level commands exported in +-- "Test.WebDriver.Commands". For more information on the wire protocol see +-- +class SessionState wd => WebDriver wd where + doCommand :: (ToJSON a, FromJSON b) => + RequestMethod -- ^HTTP request method + -> Text -- ^URL of request + -> a -- ^JSON parameters passed in the body + -- of the request. Note that, as a special case, + -- () will result in an empty request body. + -> wd b + + +modifySession :: SessionState s => (WDSession -> WDSession) -> s () +modifySession f = getSession >>= putSession . f + +{- |Information about a WebDriver session. This structure is passed +implicitly through all 'WD' computations, and is also used to configure the 'WD' +monad before execution. -} +data WDSession = WDSession { + -- |Host name of the WebDriver server for this + -- session + wdHost :: String + -- |Port number of the server + , wdPort :: Word16 + -- |An opaque reference identifying the session to + -- use with 'WD' commands. + -- A value of Nothing indicates that a session + -- hasn't been created yet. + -- Sessions can be created within 'WD' via + -- 'Test.WebDriver.createSession', or created + -- and closed automatically with + -- 'Test.WebDriver.runSession' + , wdSessId :: Maybe SessionId + } deriving (Eq, Show) + +instance Default WDSession where + def = WDSession { wdHost = "127.0.0.1" + , wdPort = 4444 + , wdSessId = Nothing + } + +{- |A default session connects to localhost on port 4444, and hasn't been +initialized server-side. This value is the same as 'def' but with a less +polymorphic type. -} +defaultSession :: WDSession +defaultSession = def + + +{- |An opaque identifier for a WebDriver session. These handles are produced by +the server on session creation, and act to identify a session in progress. -} +newtype SessionId = SessionId Text + deriving (Eq, Ord, Show, Read, + FromJSON, ToJSON) + + +instance Exception NoSessionId +-- |A command requiring a session ID was attempted when no session ID was +-- available. +newtype NoSessionId = NoSessionId String + deriving (Eq, Show, Typeable) + + +-- |This a convenient wrapper around doCommand that automatically prepends +-- the session URL parameter to the wire command URL. For example, passing +-- a URL of "/refresh" will expand to "/session/:sessionId/refresh". +doSessCommand :: (WebDriver wd, ToJSON a, FromJSON b) => + RequestMethod -> Text -> a -> wd b +doSessCommand method path args = do + WDSession { wdSessId = mSessId } <- getSession + case mSessId of + Nothing -> throwIO . NoSessionId $ msg + where + msg = "No session ID found when making request for relative URL " + ++ show path + Just (SessionId sId) -> doCommand method + (T.concat ["/session/", sId, path]) args + + +instance SessionState m => SessionState (LS.StateT s m) where + getSession = lift getSession + putSession = lift . putSession + +instance WebDriver wd => WebDriver (LS.StateT s wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance SessionState m => SessionState (SS.StateT s m) where + getSession = lift getSession + putSession = lift . putSession + +instance WebDriver wd => WebDriver (SS.StateT s wd) where + doCommand rm t a = lift (doCommand rm t a) + +instance SessionState m => SessionState (MaybeT m) where + getSession = lift getSession + putSession = lift . putSession + +instance WebDriver wd => WebDriver (MaybeT wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance SessionState m => SessionState (IdentityT m) where + getSession = lift getSession + putSession = lift . putSession + +instance WebDriver wd => WebDriver (IdentityT wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance (Monoid w, SessionState m) => SessionState (LW.WriterT w m) where + getSession = lift getSession + putSession = lift . putSession + +instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance SessionState m => SessionState (ReaderT r m) where + getSession = lift getSession + putSession = lift . putSession + +instance WebDriver wd => WebDriver (ReaderT r wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance (Error e, SessionState m) => SessionState (ErrorT e m) where + getSession = lift getSession + putSession = lift . putSession + +instance (Error e, WebDriver wd) => WebDriver (ErrorT e wd) where + doCommand rm t a = lift (doCommand rm t a) + + +--instance SessionState m => SessionState (ContT r m) where +-- getSession = lift getSession +-- putSession = lift . putSession + +--instance WebDriver wd => WebDriver (ContT r wd) where +-- doCommand rm t a = lift (doCommand rm t a) + + +instance (Monoid w, SessionState m) => SessionState (SRWS.RWST r w s m) where + getSession = lift getSession + putSession = lift . putSession + +instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where + doCommand rm t a = lift (doCommand rm t a) + + +instance (Monoid w, SessionState m) => SessionState (LRWS.RWST r w s m) where + getSession = lift getSession + putSession = lift . putSession + +instance (Monoid w, WebDriver wd) => WebDriver (LRWS.RWST r w s wd) where + doCommand rm t a = lift (doCommand rm t a) + diff --git a/src/Test/WebDriver/Commands.hs b/src/Test/WebDriver/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands.hs @@ -0,0 +1,750 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ExistentialQuantification, + GeneralizedNewtypeDeriving, TemplateHaskell #-} +-- |This module exports basic WD actions that can be used to interact with a +-- browser session. +module Test.WebDriver.Commands + ( -- * Sessions + createSession, closeSession, sessions, getCaps + -- * Browser interaction + -- ** Web navigation + , openPage, forward, back, refresh + -- ** Page info + , getCurrentURL, getSource, getTitle, screenshot + -- * Timeouts + , setImplicitWait, setScriptTimeout, setPageLoadTimeout + -- * Web elements + , Element(..), Selector(..) + -- ** Searching for elements + , findElem, findElems, findElemFrom, findElemsFrom + -- ** Interacting with elements + , click, submit, getText + , sendKeys, sendRawKeys, clearInput + -- ** Element information + , attr, cssProp, elemPos, elemSize + , isSelected, isEnabled, isDisplayed + , tagName, activeElem, elemInfo + -- ** Element equality + , (<==>), () + -- * Javascript + , executeJS, asyncJS + , JSArg(..) + -- * Windows + , WindowHandle(..), currentWindow + , getCurrentWindow, closeWindow, windows, focusWindow, maximize + , getWindowSize, setWindowSize, getWindowPos, setWindowPos + -- * Focusing on frames + , focusFrame, FrameSelector(..) + -- * Cookies + , Cookie(..), mkCookie + , cookies, setCookie, deleteCookie, deleteVisibleCookies + -- * Alerts + , getAlertText, replyToAlert, acceptAlert, dismissAlert + -- * Mouse gestures + , moveTo, moveToCenter, moveToFrom + , clickWith, MouseButton(..) + , mouseDown, mouseUp, withMouseDown, doubleClick + -- * HTML 5 Web Storage + -- |As of Selenium 2.21, Web Storage is only supported on iOS and + -- Android platforms + , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys + , getKey, setKey, deleteKey + -- * Mobile device support + -- ** Screen orientation + , Orientation(..) + , getOrientation, setOrientation + -- ** Geo-location + , getLocation, setLocation + -- ** Touch gestures + , touchClick, touchDown, touchUp, touchMove + , touchScroll, touchScrollFrom, touchDoubleClick + , touchLongClick, touchFlick, touchFlickFrom + -- * IME support + , availableIMEEngines, activeIMEEngine, checkIMEActive + , activateIME, deactivateIME + -- * Uploading files to remote server + -- |These functions allow you to upload a file to a remote server. + -- Note that this operation isn't supported by all WebDriver servers, + -- and the location where the file is stored is not standardized. + , uploadFile, uploadRawFile, uploadZipEntry + -- * Server information + , serverStatus + ) where + +import Test.WebDriver.Classes +import Test.WebDriver.JSON +import Test.WebDriver.Capabilities +import Test.WebDriver.Internal + +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.TH +import qualified Data.Text as T +import Data.Text (Text, splitOn, append, toUpper, toLower) +import Data.ByteString as SBS (ByteString, concat) +import Data.ByteString.Base64 as B64 +import Data.ByteString.Lazy as LBS (ByteString, toChunks) +import Network.URI +import Codec.Archive.Zip + +import Control.Applicative +import Control.Monad.State.Strict +import Control.Monad.Base +import Control.Exception (SomeException) +import Control.Exception.Lifted (throwIO, catch, handle) +import Data.Word +import Data.String (fromString) +import Data.Default +import qualified Data.Char as C + +import Prelude hiding (catch) + +-- |Get information from the server as a JSON 'Object'. For more information +-- about this object see +-- +serverStatus :: (WebDriver wd) => wd Value -- todo: make this a record type +serverStatus = doCommand GET "/status" () + + +-- |Create a new session with the given 'Capabilities'. This command +-- resets the current session ID to that of the new session. +createSession :: WebDriver wd => Capabilities -> wd WDSession +createSession caps = do + sessUrl <- doCommand POST "/session" . single "desiredCapabilities" $ caps + let sessId = SessionId . last . filter (not . T.null) . splitOn "/" $ sessUrl + modifySession $ \sess -> sess {wdSessId = Just sessId} + return =<< getSession + +-- |Retrieve a list of active sessions and their 'Capabilities'. +sessions :: WebDriver wd => wd [(SessionId, Capabilities)] +sessions = do + objs <- doCommand GET "/sessions" () + forM objs $ parsePair "id" "capabilities" "sessions" + +-- |Get the actual 'Capabilities' of the current session. +getCaps :: WebDriver wd => wd Capabilities +getCaps = doSessCommand GET "" () + +-- |Close the current session and the browser associated with it. +closeSession :: WebDriver wd => wd () +closeSession = do s <- getSession + doSessCommand DELETE "" () :: WebDriver wd => wd () + putSession s { wdSessId = Nothing } + +-- |Sets the amount of time we implicitly wait when searching for elements. +setImplicitWait :: WebDriver wd => Integer -> wd () +setImplicitWait ms = + doSessCommand POST "/timeouts/implicit_wait" (object msField) + `catch` \(_ :: SomeException) -> + doSessCommand POST "/timeouts" (object allFields) + where msField = ["ms" .= ms] + allFields = ["type" .= ("implicit" :: String)] ++ msField + +-- |Sets the amount of time we wait for an asynchronous script to return a +-- result. +setScriptTimeout :: WebDriver wd => Integer -> wd () +setScriptTimeout ms = + doSessCommand POST "/timeouts/async_script" (object msField) + `catch` \(_ :: SomeException) -> + doSessCommand POST "/timeouts" (object allFields) + where msField = ["ms" .= ms] + allFields = ["type" .= ("script" :: String)] ++ msField + +-- |Sets the amount of time to wait for a page to finish loading before throwing a 'Timeout' exception +setPageLoadTimeout :: WebDriver wd => Integer -> wd () +setPageLoadTimeout ms = doSessCommand POST "/timeouts" params + where params = object ["type" .= ("page load" :: String) + ,"ms" .= ms ] + +-- |Gets the URL of the current page. +getCurrentURL :: WebDriver wd => wd String +getCurrentURL = doSessCommand GET "/url" () + +-- |Opens a new page by the given URL. +openPage :: WebDriver wd => String -> wd () +openPage url + | isURI url = doSessCommand POST "/url" . single "url" $ url + | otherwise = throwIO . InvalidURL $ url + +-- |Navigate forward in the browser history. +forward :: WebDriver wd => wd () +forward = doSessCommand POST "/forward" () + +-- |Navigate backward in the browser history. +back :: WebDriver wd => wd () +back = doSessCommand POST "/back" () + +-- |Refresh the current page +refresh :: WebDriver wd => wd () +refresh = doSessCommand POST "/refresh" () + +-- |An existential wrapper for any 'ToJSON' instance. This allows us to pass +-- parameters of many different types to Javascript code. +data JSArg = forall a. ToJSON a => JSArg a + +instance ToJSON JSArg where + toJSON (JSArg a) = toJSON a + +{- |Inject a snippet of Javascript into the page for execution in the +context of the currently selected frame. The executed script is +assumed to be synchronous and the result of evaluating the script is +returned and converted to an instance of FromJSON. + +The first parameter defines arguments to pass to the javascript +function. Arguments of type Element will be converted to the +corresponding DOM element. Likewise, any elements in the script result +will be returned to the client as Elements. + +The second parameter defines the script itself in the form of a +function body. The value returned by that function will be returned to +the client. The function will be invoked with the provided argument +list and the values may be accessed via the arguments object in the +order specified. +-} +executeJS :: (WebDriver wd, FromJSON a) => [JSArg] -> Text -> wd a +executeJS a s = fromJSON' =<< getResult + where + getResult = doSessCommand POST "/execute" . pair ("args", "script") $ (a,s) + +{- |Executes a snippet of Javascript code asynchronously. This function works +similarly to 'executeJS', except that the Javascript is passed a callback +function as its final argument. The script should call this function +to signal that it has finished executing, passing to it a value that will be +returned as the result of asyncJS. A result of Nothing indicates that the +Javascript function timed out (see 'setScriptTimeout') +-} +asyncJS :: (WebDriver wd, FromJSON a) => [JSArg] -> Text -> wd (Maybe a) +asyncJS a s = handle timeout $ fromJSON' =<< getResult + where + getResult = doSessCommand POST "/execute_async" . pair ("args", "script") + $ (a,s) + timeout (FailedCommand Timeout _) = return Nothing + timeout err = throwIO err + +-- |Grab a screenshot of the current page as a PNG image +screenshot :: WebDriver wd => wd SBS.ByteString +screenshot = B64.decodeLenient <$> doSessCommand GET "/screenshot" () + + +availableIMEEngines :: WebDriver wd => wd [Text] +availableIMEEngines = doSessCommand GET "/ime/available_engines" () + +activeIMEEngine :: WebDriver wd => wd Text +activeIMEEngine = doSessCommand GET "/ime/active_engine" () + +checkIMEActive :: WebDriver wd => wd Bool +checkIMEActive = doSessCommand GET "/ime/activated" () + +activateIME :: WebDriver wd => Text -> wd () +activateIME = doSessCommand POST "/ime/activate" . single "engine" + +deactivateIME :: WebDriver wd => wd () +deactivateIME = doSessCommand POST "/ime/deactivate" () + + +-- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame' +data FrameSelector = WithIndex Integer + -- |focus on a frame by name or ID + | WithName Text + -- |focus on a frame 'Element' + | WithElement Element + -- |focus on the first frame, or the main document + -- if iframes are used. + | DefaultFrame + deriving (Eq, Show, Read) + +instance ToJSON FrameSelector where + toJSON s = case s of + WithIndex i -> toJSON i + WithName n -> toJSON n + WithElement e -> toJSON e + DefaultFrame -> Null + +-- |Switch focus to the frame specified by the FrameSelector. +focusFrame :: WebDriver wd => FrameSelector -> wd () +focusFrame s = doSessCommand POST "/frame" . single "id" $ s + +{- |An opaque identifier for a browser window -} +newtype WindowHandle = WindowHandle Text + deriving (Eq, Ord, Show, Read, + FromJSON, ToJSON) +instance Default WindowHandle where + def = currentWindow + +-- |A special 'WindowHandle' that always refers to the currently focused window. +-- This is also used by the 'Default' instance. +currentWindow :: WindowHandle +currentWindow = WindowHandle "current" + +-- |Returns a handle to the currently focused window +getCurrentWindow :: WebDriver wd => wd WindowHandle +getCurrentWindow = doSessCommand GET "/window_handle" () + +-- |Returns a list of all windows available to the session +windows :: WebDriver wd => wd [WindowHandle] +windows = doSessCommand GET "/window_handles" () + +focusWindow :: WebDriver wd => WindowHandle -> wd () +focusWindow w = doSessCommand POST "/window" . single "name" $ w + +-- |Closes the given window +closeWindow :: WebDriver wd => WindowHandle -> wd () +closeWindow = doSessCommand DELETE "/window" . single "name" + +-- |Maximizes the current window if not already maximized +maximize :: WebDriver wd => wd () +maximize = doWinCommand GET currentWindow "/maximize" () + +-- |Get the dimensions of the current window. +getWindowSize :: WebDriver wd => wd (Word, Word) +getWindowSize = doWinCommand GET currentWindow "/size" () + >>= parsePair "width" "height" "getWindowSize" + +-- |Set the dimensions of the current window. +setWindowSize :: WebDriver wd => (Word, Word) -> wd () +setWindowSize = doWinCommand POST currentWindow "/size" + . pair ("width", "height") + +-- |Get the coordinates of the current window. +getWindowPos :: WebDriver wd => wd (Int, Int) +getWindowPos = doWinCommand GET currentWindow "/position" () + >>= parsePair "x" "y" "getWindowPos" + +-- |Set the coordinates of the current window. +setWindowPos :: WebDriver wd => (Int, Int) -> wd () +setWindowPos = doWinCommand POST currentWindow "/position" . pair ("x","y") + +doWinCommand :: (WebDriver wd, ToJSON a, FromJSON b) => + RequestMethod -> WindowHandle -> Text -> a -> wd b +doWinCommand m (WindowHandle w) path a = + doSessCommand m (T.concat ["/window/", w, path]) a + +-- |Cookies are delicious delicacies. When sending cookies to the server, a value +-- of Nothing indicates that the server should use a default value. When receiving +-- cookies from the server, a value of Nothing indicates that the server is unable +-- to specify the value. +data Cookie = Cookie { cookName :: Text + , cookValue :: Text -- ^ + , cookPath :: Maybe Text -- ^path of this cookie. + -- if Nothing, defaults to / + , cookDomain :: Maybe Text -- ^domain of this cookie. + -- if Nothing, the current pages + -- domain is used + , cookSecure :: Maybe Bool -- ^Is this cookie secure? + , cookExpiry :: Maybe Integer -- ^Expiry date expressed as + -- seconds since the Unix epoch + -- Nothing indicates that the + -- cookie never expires + } deriving (Eq, Show) + +-- |Creates a Cookie with only a name and value specified. All other +-- fields are set to Nothing, which tells the server to use default values. +mkCookie :: Text -> Text -> Cookie +mkCookie name value = Cookie { cookName = name, cookValue = value, + cookPath = Nothing, cookDomain = Nothing, + cookSecure = Nothing, cookExpiry = Nothing + } + +-- This line causes a strange out of scope error. Moving to the bottom of the +-- file fixed it. +-- $( deriveToJSON (map C.toLower . drop 4) ''Cookie ) + +instance FromJSON Cookie where + parseJSON (Object o) = Cookie <$> req "name" + <*> req "value" + <*> opt "path" Nothing + <*> opt "domain" Nothing + <*> opt "secure" Nothing + <*> opt "expiry" Nothing + 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 "Cookie" v + +-- |Retrieve all cookies visible to the current page. +cookies :: WebDriver wd => wd [Cookie] +cookies = doSessCommand GET "/cookie" () + +-- |Set a cookie. If the cookie path is not specified, it will default to \"/\". +-- Likewise, if the domain is omitted, it will default to the current page's +-- domain +setCookie :: WebDriver wd => Cookie -> wd () +setCookie = doSessCommand POST "/cookie" . single "cookie" + +-- |Delete a cookie. This will do nothing is the cookie isn't visible to the +-- current page. +deleteCookie :: WebDriver wd => Cookie -> wd () +deleteCookie c = doSessCommand DELETE ("/cookie/" `append` cookName c) () + +-- |Delete all visible cookies on the current page. +deleteVisibleCookies :: WebDriver wd => wd () +deleteVisibleCookies = doSessCommand DELETE "/cookie" () + +-- |Get the current page source +getSource :: WebDriver wd => wd Text +getSource = doSessCommand GET "/source" () + +-- |Get the title of the current page. +getTitle :: WebDriver wd => wd Text +getTitle = doSessCommand GET "/title" () + +{- |An opaque identifier for a web page element. -} +newtype Element = Element Text + deriving (Eq, Ord, Show, Read) + +instance FromJSON Element where + parseJSON (Object o) = Element <$> o .: "ELEMENT" + parseJSON v = typeMismatch "Element" v + +instance ToJSON Element where + toJSON (Element e) = object ["ELEMENT" .= e] + +-- |Specifies element(s) within a DOM tree using various selection methods. +data Selector = ById Text + | ByName Text + | ByClass Text -- ^ (Note: multiple classes are not + -- allowed. For more control, use 'ByCSS') + | ByTag Text + | ByLinkText Text + | ByPartialLinkText Text + | ByCSS Text + | ByXPath Text + deriving (Eq, Show, Ord) + +instance ToJSON Selector where + toJSON s = case s of + ById t -> selector "id" t + ByName t -> selector "name" t + ByClass t -> selector "class name" t + ByTag t -> selector "tag name" t + ByLinkText t -> selector "link text" t + ByPartialLinkText t -> selector "partial link text" t + ByCSS t -> selector "css selector" t + ByXPath t -> selector "xpath" t + where + selector :: Text -> Text -> Value + selector sn t = object ["using" .= sn, "value" .= t] + +-- |Find an element on the page using the given element selector. +findElem :: WebDriver wd => Selector -> wd Element +findElem = doSessCommand POST "/element" + +-- |Find all elements on the page matching the given selector. +findElems :: WebDriver wd => Selector -> wd [Element] +findElems = doSessCommand POST "/elements" + +-- |Return the element that currently has focus. +activeElem :: WebDriver wd => wd Element +activeElem = doSessCommand POST "/element/active" () + +-- |Search for an element using the given element as root. +findElemFrom :: WebDriver wd => Element -> Selector -> wd Element +findElemFrom e = doElemCommand POST e "/element" + +-- |Find all elements matching a selector, using the given element as root. +findElemsFrom :: WebDriver wd => Element -> Selector -> wd [Element] +findElemsFrom e = doElemCommand POST e "/elements" + +-- |Describe the element. Returns a JSON object whose meaning is currently +-- undefined by the WebDriver protocol. +elemInfo :: WebDriver wd => Element -> wd Value +elemInfo e = doElemCommand GET e "" () + +-- |Click on an element. +click :: WebDriver wd => Element -> wd () +click e = doElemCommand POST e "/click" () + +-- |Submit a form element. This may be applied to descendents of a form element +-- as well. +submit :: WebDriver wd => Element -> wd () +submit e = doElemCommand POST e "/submit" () + +-- |Get all visible text within this element. +getText :: WebDriver wd => Element -> wd Text +getText e = doElemCommand GET e "/text" () + +-- |Send a sequence of keystrokes to an element. All modifier keys are released +-- at the end of the function. For more information about modifier keys, see +-- +sendKeys :: WebDriver wd => Text -> Element -> wd () +sendKeys t e = doElemCommand POST e "/value" . single "value" $ [t] + +-- |Similar to sendKeys, but doesn't implicitly release modifier keys +-- afterwards. This allows you to combine modifiers with mouse clicks. +sendRawKeys :: WebDriver wd => Text -> Element -> wd () +sendRawKeys t e = doElemCommand POST e "/keys" . single "value" $ [t] + +-- |Return the tag name of the given element. +tagName :: WebDriver wd => Element -> wd Text +tagName e = doElemCommand GET e "/name" () + +-- |Clear a textarea or text input element's value. +clearInput :: WebDriver wd => Element -> wd () +clearInput e = doElemCommand POST e "/clear" () + +-- |Determine if the element is selected. +isSelected :: WebDriver wd => Element -> wd Bool +isSelected e = doElemCommand GET e "/selected" () + +-- |Determine if the element is enabled. +isEnabled :: WebDriver wd => Element -> wd Bool +isEnabled e = doElemCommand GET e "/enabled" () + +-- |Determine if the element is displayed. +isDisplayed :: WebDriver wd => Element -> wd Bool +isDisplayed e = doElemCommand GET e "/displayed" () + +-- |Retrieve the value of an element's attribute +attr :: WebDriver wd => Element -> Text -> wd (Maybe Text) +attr e t = doElemCommand GET e ("/attribute/" `append` t) () + +-- |Retrieve the value of an element's computed CSS property +cssProp :: WebDriver wd => Element -> Text -> wd (Maybe Text) +cssProp e t = doElemCommand GET e ("/css/" `append` t) () + +-- |Retrieve an element's current position. +elemPos :: WebDriver wd => Element -> wd (Int, Int) +elemPos e = doElemCommand GET e "/location" () >>= parsePair "x" "y" "elemPos" + +-- |Retrieve an element's current size. +elemSize :: WebDriver wd => Element -> wd (Word, Word) +elemSize e = doElemCommand GET e "/size" () + >>= parsePair "width" "height" "elemSize" + +infix 4 <==> +-- |Determines if two element identifiers refer to the same element. +(<==>) :: WebDriver wd => Element -> Element -> wd Bool +e1 <==> (Element e2) = doElemCommand GET e1 ("/equals/" `append` e2) () + +-- |Determines if two element identifiers refer to different elements. +infix 4 +() :: WebDriver wd => Element -> Element -> wd Bool +e1 e2 = not <$> (e1 <==> e2) + +doElemCommand :: (WebDriver wd, ToJSON a, FromJSON b) => + RequestMethod -> Element -> Text -> a -> wd b +doElemCommand m (Element e) path a = + doSessCommand m (T.concat ["/element/", e, path]) a + +-- |A screen orientation +data Orientation = Landscape | Portrait + deriving (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON Orientation where + toJSON = String . toUpper . fromString . show + +instance FromJSON Orientation where + parseJSON (String jStr) = case toLower jStr of + "landscape" -> return Landscape + "portrait" -> return Portrait + err -> fail $ "Invalid Orientation string " ++ show err + parseJSON v = typeMismatch "Orientation" v + +-- |Get the current screen orientation for rotatable display devices. +getOrientation :: WebDriver wd => wd Orientation +getOrientation = doSessCommand GET "/orientation" () + +-- |Set the current screen orientation for rotatable display devices. +setOrientation :: WebDriver wd => Orientation -> wd () +setOrientation = doSessCommand POST "/orientation" . single "orientation" + +-- |Get the text of an alert dialog. +getAlertText :: WebDriver wd => wd Text +getAlertText = doSessCommand GET "/alert_text" () + +-- |Sends keystrokes to Javascript prompt() dialog. +replyToAlert :: WebDriver wd => Text -> wd () +replyToAlert = doSessCommand POST "/alert_text" . single "text" + +-- |Accepts the currently displayed alert dialog. +acceptAlert :: WebDriver wd => wd () +acceptAlert = doSessCommand POST "/accept_alert" () + +-- |Dismisses the currently displayed alert dialog. +dismissAlert :: WebDriver wd => wd () +dismissAlert = doSessCommand POST "/dismiss_alert" () + +-- |Moves the mouse to the given position relative to the active element. +moveTo :: WebDriver wd => (Int, Int) -> wd () +moveTo = doSessCommand POST "/moveto" . pair ("xoffset","yoffset") + +-- |Moves the mouse to the center of a given element. +moveToCenter :: WebDriver wd => Element -> wd () +moveToCenter (Element e) = + doSessCommand POST "/moveto" . single "element" $ e + +-- |Moves the mouse to the given position relative to the given element. +moveToFrom :: WebDriver wd => (Int, Int) -> Element -> wd () +moveToFrom (x,y) (Element e) = + doSessCommand POST "/moveto" + . triple ("element","xoffset","yoffset") $ (e,x,y) + +-- |A mouse button +data MouseButton = LeftButton | MiddleButton | RightButton + deriving (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON MouseButton where + toJSON = String . toUpper . fromString . show + +instance FromJSON MouseButton where + parseJSON (String jStr) = case toLower jStr of + "left" -> return LeftButton + "middle" -> return MiddleButton + "right" -> return RightButton + err -> fail $ "Invalid MouseButton string " ++ show err + parseJSON v = typeMismatch "MouseButton" v + +-- |Click at the current mouse position with the given mouse button. +clickWith :: WebDriver wd => MouseButton -> wd () +clickWith = doSessCommand POST "/click" . single "button" + +-- |Perform the given action with the left mouse button held down. The mouse +-- is automatically released afterwards. +withMouseDown :: WebDriver wd => wd a -> wd a +withMouseDown wd = mouseDown >> wd <* mouseUp + +-- |Press and hold the left mouse button down. Note that undefined behavior +-- occurs if the next mouse command is not mouseUp. +mouseDown :: WebDriver wd => wd () +mouseDown = doSessCommand POST "/buttondown" () + +-- |Release the left mouse button. +mouseUp :: WebDriver wd => wd () +mouseUp = doSessCommand POST "/buttonup" () + +-- |Double click at the current mouse location. +doubleClick :: WebDriver wd => wd () +doubleClick = doSessCommand POST "/doubleclick" () + +-- |Single tap on the touch screen at the given element's location. +touchClick :: WebDriver wd => Element -> wd () +touchClick (Element e) = + doSessCommand POST "/touch/click" . single "element" $ e + +-- |Emulates pressing a finger down on the screen at the given location. +touchDown :: WebDriver wd => (Int, Int) -> wd () +touchDown = doSessCommand POST "/touch/down" . pair ("x","y") + +-- |Emulates removing a finger from the screen at the given location. +touchUp :: WebDriver wd => (Int, Int) -> wd () +touchUp = doSessCommand POST "/touch/up" . pair ("x","y") + +-- |Emulates moving a finger on the screen to the given location. +touchMove :: WebDriver wd => (Int, Int) -> wd () +touchMove = doSessCommand POST "/touch/move" . pair ("x","y") + +-- |Emulate finger-based touch scroll. Use this function if you don't care where +-- the scroll begins +touchScroll :: WebDriver wd => (Int, Int) -> wd () +touchScroll = doSessCommand POST "/touch/scroll" . pair ("xoffset","yoffset") + +-- |Emulate finger-based touch scroll, starting from the given location relative +-- to the given element. +touchScrollFrom :: WebDriver wd => (Int, Int) -> Element -> wd () +touchScrollFrom (x, y) (Element e) = + doSessCommand POST "/touch/scroll" + . triple ("xoffset", "yoffset", "element") + $ (x, y, e) + +-- |Emulate a double click on a touch device. +touchDoubleClick :: WebDriver wd => Element -> wd () +touchDoubleClick (Element e) = doSessCommand POST "/touch/doubleclick" + . single "element" $ e + +-- |Emulate a long click on a touch device. +touchLongClick :: WebDriver wd => Element -> wd () +touchLongClick (Element e) = doSessCommand POST "/touch/longclick" + . single "element" $ e +-- |Emulate a flick on the touch screen. The coordinates indicate x and y +-- velocity, respectively. Use this function if you don't care where the +-- flick starts. +touchFlick :: WebDriver wd => (Int, Int) -> wd () +touchFlick = doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed") + +-- |Emulate a flick on the touch screen. +touchFlickFrom :: WebDriver wd => + Int -- ^ flick velocity + -> (Int, Int) -- ^ a location relative to the given element + -> Element -- ^ the given element + -> wd () +touchFlickFrom s (x,y) (Element e) = + doSessCommand POST "/touch/flick" . object $ + ["xoffset" .= x + ,"yoffset" .= y + ,"speed" .= s + ,"element" .= e + ] + +-- |Get the current geographical location of the device. +getLocation :: WebDriver wd => wd (Int, Int, Int) +getLocation = doSessCommand GET "/location" () + >>= parseTriple "latitude" "longitude" "altitude" "getLocation" + +-- |Set the current geographical location of the device. +setLocation :: WebDriver wd => (Int, Int, Int) -> wd () +setLocation = doSessCommand POST "/location" . triple ("latitude", + "longitude", + "altitude") + +-- |Uploads a file from the local filesystem by its file path. +uploadFile :: WebDriver wd => FilePath -> wd () +uploadFile path = uploadZipEntry =<< liftBase (readEntry [] path) + +-- |Uploads a raw bytestring with associated file info. +uploadRawFile :: WebDriver wd => + FilePath -- ^File path to use with this bytestring. + -> Integer -- ^Modification time + -- (in seconds since Unix epoch). + -> LBS.ByteString -- ^ The file contents as a lazy ByteString + -> wd () +uploadRawFile path t str = uploadZipEntry (toEntry path t str) + + +-- |Lowest level interface to the file uploading mechanism. +-- This allows you to specify the exact details of +-- the zip entry sent across network. +uploadZipEntry :: WebDriver wd => Entry -> wd () +uploadZipEntry = doSessCommand POST "/file" . single "file" + . B64.encode . SBS.concat . toChunks + . fromArchive . (`addEntryToArchive` emptyArchive) + + +-- |An HTML 5 storage type +data WebStorageType = LocalStorage | SessionStorage + deriving (Eq, Show, Ord, Bounded, Enum) + +-- |Get the current number of keys in a web storage area. +storageSize :: WebDriver wd => WebStorageType -> wd Integer +storageSize s = doStorageCommand GET s "/size" () + +-- |Get a list of all keys from a web storage area. +getAllKeys :: WebDriver wd => WebStorageType -> wd [Text] +getAllKeys s = doStorageCommand GET s "" () + +-- |Delete all keys within a given web storage area. +deleteAllKeys :: WebDriver wd => WebStorageType -> wd () +deleteAllKeys s = doStorageCommand DELETE s "" () + +-- |Get the value associated with a key in the given web storage area. +-- Unset keys result in empty strings, since the Web Storage spec +-- makes no distinction between the empty string and an undefined value. +getKey :: WebDriver wd => WebStorageType -> Text -> wd Text +getKey s k = doStorageCommand GET s ("/key/" `T.append` k) () + +-- |Set a key in the given web storage area. +setKey :: WebDriver wd => WebStorageType -> Text -> Text -> wd Text +setKey s k v = doStorageCommand POST s "" . object $ ["key" .= k, + "value" .= v ] +-- |Delete a key in the given web storage area. +deleteKey :: WebDriver wd => WebStorageType -> Text -> wd () +deleteKey s k = doStorageCommand POST s ("/key/" `T.append` k) () + +doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) => + RequestMethod -> WebStorageType -> Text -> a -> wd b +doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a + where s' = case s of + LocalStorage -> "local_storage" + SessionStorage -> "session_storage" + +$( deriveToJSON (map C.toLower . drop 4) ''Cookie ) diff --git a/src/Test/WebDriver/Commands/Wait.hs b/src/Test/WebDriver/Commands/Wait.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Wait.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, FlexibleContexts #-} +module Test.WebDriver.Commands.Wait + ( -- * Wait on expected conditions + waitUntil, waitUntil' + , waitWhile, waitWhile' + -- * Expected conditions + , ExpectFailed, expect, unexpected + -- ** Convenience functions + , expectAny, expectAll + , (<||>), (<&&>) + ) where +import Test.WebDriver.Exceptions +import Test.WebDriver.Classes +import Control.Monad +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Exception.Lifted +import Control.Concurrent +import Data.Time.Clock +import Data.Typeable +import Prelude hiding (catch) + +instance Exception ExpectFailed +-- |An exception representing the failure of an expected condition. +data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable) + +-- |throws 'ExpectFailed'. This is nice for writing your own abstractions. +unexpected :: MonadBaseControl IO m => m a +unexpected = throwIO ExpectFailed + +-- |An expected condition. This function allows you to express assertions in +-- your explicit wait. This function raises 'ExpectFailed' if the given +-- boolean is False, and otherwise does nothing. +expect :: MonadBaseControl IO m => Bool -> m () +expect b + | b = return () + | otherwise = unexpected + + +-- |Lifted boolean and +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +(<&&>) = liftM2 (&&) + +-- |Lifted boolean or +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +(<||>) = liftM2 (||) + + +-- |Apply a predicate to every element in a list, and expect that at least one +-- succeeds. +expectAny :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m () +expectAny p xs = expect . or =<< mapM p xs + +-- |Apply a predicate to every element in a list, and expect that all succeed. +expectAll :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m () +expectAll p xs = expect . and =<< mapM p xs + +-- |Wait until either the given action succeeds or the timeout is reached. +-- The action will be retried every .25 seconds until no 'ExpectFailed' or +-- 'Test.WebDriver.NoSuchElement' exceptions occur. If the timeout is reached, +-- then a 'Test.WebDriver.Timeout' exception will be raised. The timeout value +-- is expressed in seconds. +waitUntil :: SessionState m => Double -> m a -> m a +waitUntil = waitUntil' 250000 + +-- |Similar to 'waitUntil' but allows you to also specify the poll frequency +-- of the 'WD' action. The frequency is expressed as an integer in microseconds. +waitUntil' :: SessionState m => Int -> Double -> m a -> m a +waitUntil' = wait' handler + where + handler retry = (`catches` [Handler handleFailedCommand + ,Handler handleExpectFailed] + ) + where + handleFailedCommand (FailedCommand NoSuchElement _) = retry + handleFailedCommand err = throwIO err + + handleExpectFailed (_ :: ExpectFailed) = retry + +-- |Like 'waitUntil', but retries the action until it fails or until the timeout +-- is exceeded. +waitWhile :: SessionState m => Double -> m a -> m () +waitWhile = waitWhile' 250000 + +-- |Like 'waitUntil'', but retries the action until it either fails or +-- until the timeout is exceeded. +waitWhile' :: SessionState m => Int -> Double -> m a -> m () +waitWhile' = wait' handler + where + handler retry wd = do + void wd `catches` [Handler handleFailedCommand + ,Handler handleExpectFailed + ] + retry + where + handleFailedCommand (FailedCommand NoSuchElement _) = return () + handleFailedCommand err = throwIO err + + handleExpectFailed (_ :: ExpectFailed) = return () + +wait' :: SessionState m => + (m b -> m a -> m b) -> Int -> Double -> m a -> m b +wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime + where timeout = realToFrac t + waitLoop startTime = handler retry wd + where + retry = do + now <- liftBase getCurrentTime + if diffUTCTime now startTime >= timeout + then + failedCommand Timeout "waitUntil': explicit wait timed out." + else do + liftBase . threadDelay $ waitAmnt + waitLoop startTime diff --git a/src/Test/WebDriver/Common/Profile.hs b/src/Test/WebDriver/Common/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Common/Profile.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_HADDOCK not-home #-} +-- |A type for profile preferences. These preference values are used by both +-- Firefox and Opera profiles. +module Test.WebDriver.Common.Profile + ( Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..) + , getPref, addPref, deletePref, addExtension, deleteExtension + , ProfileParseError(..) ) where + +import Data.Aeson +import Data.Aeson.Types +import Data.Attoparsec.Number (Number(..)) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Text (Text, pack) +import Data.ByteString (ByteString) + +import Data.Fixed +import Data.Ratio +import Data.Int +import Data.Word + +import Data.Typeable +import Control.Exception + +-- |This structure allows you to construct and manipulate profiles in pure code, +-- deferring execution of IO operations until the profile is \"prepared\". This +-- type is shared by both Firefox and Opera profile code; when a distinction +-- must be made, the phantom type parameter is used to differentiate. +data Profile b = Profile + { -- |Location of the profile in the local file system + profileDir :: FilePath + -- |A set of filepaths pointing to browser extensions. + , profileExts :: HS.HashSet FilePath + -- |A map of Firefox preferences. These are the settings + -- found in the profile's prefs.js, and entries found in + -- about:config + , profilePrefs :: HM.HashMap Text ProfilePref + } + deriving (Eq, Show) + +-- |Represents a profile that has been prepared for +-- network transmission. The profile cannot be modified in this form. +newtype PreparedProfile b = PreparedProfile ByteString + deriving (Eq, Show, ToJSON, FromJSON) + +-- |A profile preference value. This is the subset of JSON values that excludes +-- arrays, objects, and null. +data ProfilePref = PrefInteger !Integer + | PrefDouble !Double + | PrefString !Text + | PrefBool !Bool + deriving (Eq, Show) + +instance ToJSON ProfilePref where + toJSON v = case v of + PrefInteger i -> toJSON i + PrefDouble d -> toJSON d + PrefString s -> toJSON s + PrefBool b -> toJSON b + +instance FromJSON ProfilePref where + parseJSON (String s) = return $ PrefString s + parseJSON (Bool b) = return $ PrefBool b + parseJSON (Number (I i)) = return $ PrefInteger i + parseJSON (Number (D d)) = return $ PrefDouble d + parseJSON other = typeMismatch "ProfilePref" other + +instance Exception ProfileParseError +-- |An error occured while attempting to parse a profile's preference file. +newtype ProfileParseError = ProfileParseError String + deriving (Eq, Show, Read, Typeable) + +-- |A typeclass to convert types to profile preference values +class ToPref a where + toPref :: a -> ProfilePref + +instance ToPref Text where + toPref = PrefString + +instance ToPref String where + toPref = toPref . pack + +instance ToPref Bool where + toPref = PrefBool + +instance ToPref Integer where + toPref = PrefInteger + +#define I(t) instance ToPref t where toPref = PrefInteger . toInteger + +I(Int) +I(Int8) +I(Int16) +I(Int32) +I(Int64) +I(Word) +I(Word8) +I(Word16) +I(Word32) +I(Word64) + +instance ToPref Double where + toPref = PrefDouble + +instance ToPref Float where + toPref = PrefDouble . realToFrac + +instance (Integral a) => ToPref (Ratio a) where + toPref = PrefDouble . realToFrac + +instance (HasResolution r) => ToPref (Fixed r) where + toPref = PrefDouble . realToFrac + + +-- |Retrieve a preference from a profile by key name. +getPref :: Text -> Profile b -> Maybe ProfilePref +getPref k (Profile _ _ m) = HM.lookup k m + +-- |Add a new preference entry to a profile, overwriting any existing entry +-- with the same key. +addPref :: ToPref a => Text -> a -> Profile b -> Profile b +addPref k v p = asMap p $ HM.insert k (toPref v) + +-- |Delete an existing preference entry from a profile. This operation is +-- silent if the preference wasn't found. +deletePref :: Text -> Profile b -> Profile b +deletePref k p = asMap p $ HM.delete k + +-- |Add a new extension to the profile. The file path should refer to +-- an .xpi file or an extension directory. This operation has no effect if +-- the same extension has already been added to this profile. +addExtension :: FilePath -> Profile b -> Profile b +addExtension path p = asSet p $ HS.insert path + +-- |Delete an existing extension from the profile. The file path should refer +-- to an .xpi file or an extension directory. This operation has no effect if +-- the extension was never added to the profile. +deleteExtension :: FilePath -> Profile b -> Profile b +deleteExtension path p = asSet p $ HS.delete path + +asMap :: Profile b + -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref) + -> Profile b +asMap (Profile p hs hm) f = Profile p hs (f hm) + +asSet :: Profile b + -> (HS.HashSet FilePath -> HS.HashSet FilePath) + -> Profile b +asSet (Profile p hs hm) f = Profile p (f hs) hm diff --git a/src/Test/WebDriver/Exceptions.hs b/src/Test/WebDriver/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Exceptions.hs @@ -0,0 +1,11 @@ +module Test.WebDriver.Exceptions + ( InvalidURL(..), NoSessionId(..), BadJSON(..) + , HTTPStatusUnknown(..), HTTPConnError(..) + , UnknownCommand(..), ServerError(..) + , FailedCommand(..), FailedCommandType(..) + , FailedCommandInfo(..), StackFrame(..) + , mkFailedCommandInfo, failedCommand + )where +import Test.WebDriver.Internal +import Test.WebDriver.Classes +import Test.WebDriver.JSON diff --git a/src/Test/WebDriver/Firefox/Profile.hs b/src/Test/WebDriver/Firefox/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Firefox/Profile.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts, + GeneralizedNewtypeDeriving, EmptyDataDecls #-} +-- |A module for working with Firefox profiles. Firefox profiles are manipulated +-- in pure code and then \"prepared\" for network transmission. +module Test.WebDriver.Firefox.Profile + ( -- * Profiles + Firefox, Profile(..), PreparedProfile + -- * Preferences + , ProfilePref(..), ToPref(..) + , addPref, getPref, deletePref + -- * Extensions + , addExtension, deleteExtension + -- * Loading and preparing profiles + , loadProfile, prepareProfile + , prepareTempProfile, prepareLoadedProfile + ) where +import Test.WebDriver.Common.Profile + +import Data.Aeson +import Data.Aeson.Parser (jstring, value') +import Data.Attoparsec.Char8 as AP +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Text (Text) +import Data.ByteString as BS (readFile) +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Base64 as B64 + +import System.IO +import System.FilePath hiding (hasExtension, addExtension) +import System.Directory +import System.IO.Temp +import Codec.Archive.Zip +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Control.Monad +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Applicative +import Control.Exception.Lifted + + +-- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile' +data Firefox + +tempProfile :: MonadBase IO m => m (Profile Firefox) +tempProfile = liftBase $ defaultProfile <$> mkTemp + +-- |Load an existing profile from the file system. Any prepared changes made to +-- the 'Profile' will have no effect to the profile on disk. +loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) +loadProfile path = liftBase $ do + Profile{ profileDir = d } <- tempProfile + Profile <$> pure d <*> getExtensions <*> getPrefs + where + extD = path "extensions" + userPref = path "prefs" <.> "js" + getExtensions = HS.fromList . filter (`elem` [".",".."]) + <$> getDirectoryContents extD + getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPref) + + parsePrefs s = either (throwIO . ProfileParseError) + return + $ parseOnly prefsParser s + +-- |Prepare a firefox profile for network transmission. +-- Internally, this function constructs a Firefox profile within a temp +-- directory, archives it as a zip file, and then base64 encodes the zipped +-- data. The temporary directory is deleted afterwards +prepareProfile :: MonadBase IO m => + Profile Firefox -> m (PreparedProfile Firefox) +prepareProfile Profile {profileDir = d, profileExts = s, + profilePrefs = m} + = liftBase $ do + createDirectoryIfMissing False extensionD + extPaths <- mapM canonicalizePath . HS.toList $ s + forM_ extPaths installExtension + withFile userPrefs WriteMode writeUserPrefs + prof <- PreparedProfile . B64.encode . SBS.concat . LBS.toChunks + . fromArchive + <$> addFilesToArchive [OptRecursive] emptyArchive [d] + removeDirectoryRecursive d + return prof + where + extensionD = d "extensions" + userPrefs = d "prefs" <.> "js" + + installExtension ePath = + case splitExtension ePath of + (_,".xpi") -> installOrdinaryFile silent ePath dest + _ -> installDirectoryContents silent ePath dest + where + dest = extensionD eFile + (_,eFile) = splitFileName ePath + + writeUserPrefs h = + forM_ (HM.toList m) $ \(k, v) -> + LBS.hPut h . LBS.concat + $ [ "user_pref(", encode k, ", ", encode v, ");\n"] + + +-- |Apply a function on an automatically generated default profile, and +-- prepare the result. The Profile passed to the handler function is +-- the default profile used by sessions when Nothing is specified +prepareTempProfile :: MonadBase IO m => + (Profile Firefox -> Profile Firefox) + -> m (PreparedProfile Firefox) +prepareTempProfile f = liftM f tempProfile >>= prepareProfile + +-- |Convenience function to load an existing Firefox profile from disk, apply +-- a handler function, and then prepare the result for network transmission. +prepareLoadedProfile :: MonadBaseControl IO m => + FilePath + -> (Profile Firefox -> Profile Firefox) + -> m (PreparedProfile Firefox) +prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile + +defaultProfile :: FilePath -> Profile Firefox +defaultProfile d = + Profile d HS.empty + $ HM.fromList [("app.update.auto", PrefBool False) + ,("app.update.enabled", PrefBool False) + ,("browser.startup.page" , PrefInteger 0) + ,("browser.download.manager.showWhenStarting", PrefBool False) + ,("browser.EULA.override", PrefBool True) + ,("browser.EULA.3.accepted", PrefBool True) + ,("browser.link.open_external", PrefInteger 2) + ,("browser.link.open_newwindow", PrefInteger 2) + ,("browser.offline", PrefBool False) + ,("browser.safebrowsing.enabled", PrefBool False) + ,("browser.search.update", PrefBool False) + ,("browser.sessionstore.resume_from_crash", PrefBool False) + ,("browser.shell.checkDefaultBrowser", PrefBool False) + ,("browser.tabs.warnOnClose", PrefBool False) + ,("browser.tabs.warnOnOpen", PrefBool False) + ,("browser.startup.page", PrefInteger 0) + ,("browser.safebrowsing.malware.enabled", PrefBool False) + ,("startup.homepage_welcome_url", PrefString "about:blank") + ,("devtools.errorconsole.enabled", PrefBool True) + ,("focusmanager.testmode", PrefBool True) + ,("dom.disable_open_during_load", PrefBool False) + ,("extensions.autoDisableScopes" , PrefInteger 10) + ,("extensions.logging.enabled", PrefBool True) + ,("extensions.update.enabled", PrefBool False) + ,("extensions.update.notifyUser", PrefBool False) + ,("network.manage-offline-status", PrefBool False) + ,("network.http.max-connections-per-server", PrefInteger 10) + ,("network.http.phishy-userpass-length", PrefInteger 255) + ,("offline-apps.allow_by_default", PrefBool True) + ,("prompts.tab_modal.enabled", PrefBool False) + ,("security.fileuri.origin_policy", PrefInteger 3) + ,("security.fileuri.strict_origin_policy", PrefBool False) + ,("security.warn_entering_secure", PrefBool False) + ,("security.warn_submit_insecure", PrefBool False) + ,("security.warn_entering_secure.show_once", PrefBool False) + ,("security.warn_entering_weak", PrefBool False) + ,("security.warn_entering_weak.show_once", PrefBool False) + ,("security.warn_leaving_secure", PrefBool False) + ,("security.warn_leaving_secure.show_once", PrefBool False) + ,("security.warn_submit_insecure", PrefBool False) + ,("security.warn_viewing_mixed", PrefBool False) + ,("security.warn_viewing_mixed.show_once", PrefBool False) + ,("signon.rememberSignons", PrefBool False) + ,("toolkit.networkmanager.disable", PrefBool True) + ,("toolkit.telemetry.enabled", PrefBool False) + ,("toolkit.telemetry.prompted", PrefInteger 2) + ,("toolkit.telemetry.rejected", PrefBool True) + ,("javascript.options.showInConsole", PrefBool True) + ,("browser.dom.window.dump.enabled", PrefBool True) + ,("webdriver_accept_untrusted_certs", PrefBool True) + ,("webdriver_enable_native_events", native_events) + ,("webdriver_assume_untrusted_issuer", PrefBool True) + ,("dom.max_script_run_time", PrefInteger 30) + ] + where +#ifdef darwin_HOST_OS + native_events = PrefBool False +#else + native_events = PrefBool True +#endif + +mkTemp :: IO FilePath +mkTemp = do + d <- getTemporaryDirectory + createTempDirectory d "" + +-- firefox prefs.js parser + +prefsParser :: Parser [(Text, ProfilePref)] +prefsParser = many $ do + padSpaces $ string "user_pref(" + k <- prefKey "preference key" + padSpaces $ char ',' + v <- prefVal "preference value" + padSpaces $ string ");" + endOfLine + return (k,v) + where + prefKey = jstring + prefVal = do + v <- value' + case fromJSON v of + Error str -> fail str + Success p -> return p + spaces = AP.takeWhile isSpace + padSpaces p = spaces >> p <* spaces diff --git a/src/Test/WebDriver/Internal.hs b/src/Test/WebDriver/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Internal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, DeriveDataTypeable #-} +module Test.WebDriver.Internal + ( mkWDUri, mkRequest + , handleHTTPErr, handleJSONErr, handleHTTPResp + + , 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, emptyArray) + +import Data.Text as T (Text, unpack) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.ByteString.Lazy.Char8 as BS (length, unpack, null) +import qualified Data.ByteString.Char8 as SBS (ByteString) +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Vector as V + +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 (fromJust, fromMaybe) +import Data.String (fromString) +import Data.Word (Word, Word8) + +mkWDUri :: (SessionState s) => String -> s URI --todo: remove String :( +mkWDUri path = do + WDSession{wdHost = host, + wdPort = port + } <- getSession + let urlStr = "http://" ++ host ++ ":" ++ show port + relPath = "/wd/hub" ++ path + mBaseURI = parseAbsoluteURI urlStr + mRelURI = parseRelativeReference relPath + case (mBaseURI, mRelURI) of + (Nothing, _) -> throwIO $ InvalidURL urlStr + (_, Nothing) -> throwIO $ InvalidURL relPath + (Just baseURI, Just relURI) -> return . fromJust $ relURI `relativeTo` baseURI + +mkRequest :: (SessionState s, ToJSON a) => + [Header] -> RequestMethod -> Text -> a -> s (Response ByteString) +mkRequest headers method path args = do + uri <- mkWDUri (T.unpack path) + let body = case toJSON args of + Array v | V.null v -> "" --an ugly corner case to allow empty requests + other -> encode other + req = Request { rqURI = uri --todo: normalization of headers + , rqMethod = method + , rqBody = body + , rqHeaders = headers ++ [ Header HdrAccept + "application/json;charset=UTF-8" + , Header HdrContentType + "application/json;charset=UTF-8" + , Header HdrContentLength + . show . BS.length $ body + ] + } +-- liftIO . print $ req + liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return + +handleHTTPErr :: SessionState s => Response ByteString -> s () +handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = + case code of + (4,_,_) -> err UnknownCommand + (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,2) -> 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) -> returnEmptyArray + (3,0,2) -> fromJSON' =<< maybe statusErr (return . String . fromString) + (findHeader HdrLocation resp) + where + statusErr = throwIO . HTTPStatusUnknown code + $ (BS.unpack body) + other + | BS.null body -> returnEmptyArray + | otherwise -> fromJSON' . rspVal =<< parseJSON' body + where + returnEmptyArray = fromJSON' emptyArray + +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 + 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" + <*> o .: "status" + <*> o .: "value" .!= Null + parseJSON v = typeMismatch "WDResponse" v + + +instance Exception InvalidURL +-- |An invalid URL was given +newtype InvalidURL = InvalidURL String + deriving (Eq, Show, Typeable) + +instance Exception HTTPStatusUnknown +-- |An unexpected HTTP status was sent by the server. +data HTTPStatusUnknown = HTTPStatusUnknown (Int, Int, Int) String + deriving (Eq, Show, Typeable) + +instance Exception HTTPConnError +-- |HTTP connection errors. +newtype HTTPConnError = HTTPConnError ConnError + deriving (Eq, Show, Typeable) + +instance Exception UnknownCommand +-- |A command was sent to the WebDriver server that it didn't recognize. +newtype UnknownCommand = UnknownCommand String + deriving (Eq, Show, Typeable) + +instance Exception ServerError +-- |A server-side exception occured +newtype ServerError = ServerError String + deriving (Eq, Show, Typeable) + +instance Exception FailedCommand +-- |This exception encapsulates a broad variety of exceptions that can +-- occur when a command fails. +data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo + deriving (Eq, Show, Typeable) + +-- |The type of failed command exception that occured. +data FailedCommandType = NoSuchElement + | NoSuchFrame + | UnknownFrame + | StaleElementReference + | ElementNotVisible + | InvalidElementState + | UnknownError + | ElementIsNotSelectable + | JavascriptError + | XPathLookupError + | Timeout + | NoSuchWindow + | InvalidCookieDomain + | UnableToSetCookie + | UnexpectedAlertOpen + | NoAlertOpen + | ScriptTimeout + | InvalidElementCoordinates + | IMENotAvailable + | IMEEngineActivationFailed + | InvalidSelector + | MoveTargetOutOfBounds + | InvalidXPathSelector + | InvalidXPathSelectorReturnType + | MethodNotAllowed + deriving (Eq, Ord, Enum, Bounded, Show) + +-- |Detailed information about the failed command provided by the server. +data FailedCommandInfo = + FailedCommandInfo { -- |The error message. + errMsg :: String + -- |The session associated with + -- the exception. + , errSess :: WDSession + -- |A screen shot of the focused window + -- when the exception occured, + -- if provided. + , errScreen :: Maybe SBS.ByteString + -- |The "class" in which the exception + -- was raised, if provided. + , errClass :: Maybe String + -- |A stack trace of the exception. + , errStack :: [StackFrame] + } + deriving (Eq) + +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 "" . errClass $ i + + sess = showString sessId . showString " at " + . showString host . showChar ':' . shows port + where + sessId = case msid of + Just (SessionId sid) -> T.unpack sid + Nothing -> "" + WDSession {wdHost = host, wdPort = port, wdSessId = msid } = errSess i + + +-- |Constructs a FailedCommandInfo from only an error message. +mkFailedCommandInfo :: SessionState s => String -> s FailedCommandInfo +mkFailedCommandInfo m = do + sess <- getSession + return $ FailedCommandInfo {errMsg = m , errSess = sess , errScreen = Nothing + , errClass = Nothing , errStack = [] } + +-- |Convenience function to throw a 'FailedCommand' locally with no server-side +-- info present. +failedCommand :: SessionState s => FailedCommandType -> String -> s a +failedCommand t m = throwIO . FailedCommand t =<< mkFailedCommandInfo m + +-- |An individual stack frame from the stack trace provided by the server +-- during a FailedCommand. +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 + <*> opt "screen" Nothing + <*> opt "class" Nothing + <*> opt "stackTrace" [] + where req :: FromJSON a => Text -> Parser a + req = (o .:) --required key + opt :: FromJSON a => Text -> a -> Parser a + opt k d = o .:? k .!= d --optional key + 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 .:) -- all keys are required + reqStr :: Text -> Parser String + reqStr k = req k >>= maybe (return "") return + parseJSON v = typeMismatch "StackFrame" v + + diff --git a/src/Test/WebDriver/JSON.hs b/src/Test/WebDriver/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/JSON.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, DeriveDataTypeable #-} +-- |A collection of convenience functions for using and parsing JSON values +-- within 'WD'. All monadic parse errors are converted to asynchronous +-- 'BadJSON' exceptions. +module Test.WebDriver.JSON + ( -- * Access a JSON object key + (!:) + -- * Conversion from JSON within WD + -- |Apostrophes are used to disambiguate these functions + -- from their "Data.Aeson" counterparts. + , parseJSON', fromJSON' + -- * Tuple functions + -- |Convenience functions for working with tuples. + + -- ** JSON object constructors + , single, pair, triple + -- ** Extracting JSON objects into tuples + , parsePair, parseTriple + -- * Conversion from parser results to WD + -- |These functions are used to implement the other functions + -- in this module, and could be used to implement other JSON + -- convenience functions + , apResultToWD, aesonResultToWD + -- * Parse exception + , BadJSON(..) + ) where + +import Data.Aeson as Aeson +import Data.Aeson.Types +import Data.Text (Text) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Attoparsec.ByteString.Lazy (Result(..)) +import qualified Data.Attoparsec.ByteString.Lazy as AP + +import Control.Applicative +import Control.Monad.Trans.Control +import Control.Exception.Lifted +import Data.String +import Data.Typeable + +instance Exception BadJSON +-- |An error occured when parsing a JSON value. +newtype BadJSON = BadJSON String + deriving (Eq, Show, Typeable) + +-- |Construct a singleton JSON 'object' from a key and value. +single :: ToJSON a => Text -> a -> Value +single a x = object [a .= x] + +-- |Construct a 2-element JSON 'object' from a pair of keys and a pair of +-- values. +pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value +pair (a,b) (x,y) = object [a .= x, b .= y] + +-- |Construct a 3-element JSON 'object' from a triple of keys and a triple of +-- values. +triple :: (ToJSON a, ToJSON b, ToJSON c) => + (Text,Text,Text) -> (a,b,c) -> Value +triple (a,b,c) (x,y,z) = object [a .= x, b.= y, c .= z] + + +-- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an +-- instance of 'FromJSON'.. +parseJSON' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a +parseJSON' = apResultToWD . AP.parse json + +-- |Convert a JSON 'Value' to an instance of 'FromJSON'. +fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a +fromJSON' = aesonResultToWD . fromJSON + +-- |This operator is a wrapper over Aeson's '.:' operator. +(!:) :: (MonadBaseControl IO wd, FromJSON a) => Object -> Text -> wd a +o !: k = aesonResultToWD $ parse (.: k) o + + +-- |Parse a JSON 'Object' as a pair. The first two string arguments specify the +-- keys to extract from the object. The third string is the name of the +-- calling function, for better error reporting. +parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) => + String -> String -> String -> Value -> wd (a, b) +parsePair a b funcName v = + case v of + Object o -> (,) <$> o !: fromString a <*> o !: fromString b + _ -> throwIO . BadJSON $ funcName ++ + ": cannot parse non-object JSON response as a (" ++ a + ++ ", " ++ b ++ ") pair" ++ ")" + + +-- |Parse a JSON Object as a triple. The first three string arguments +-- specify the keys to extract from the object. The fourth string is the name +-- of the calling function, for better error reporting. +parseTriple :: (MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) => + String -> String -> String -> String -> Value -> wd (a, b, c) +parseTriple a b c funcName v = + case v of + Object o -> (,,) <$> o !: fromString a + <*> o !: fromString b + <*> o !: fromString c + _ -> throwIO . BadJSON $ funcName ++ + ": cannot parse non-object JSON response as a (" ++ a + ++ ", " ++ b ++ ", " ++ c ++ ") pair" + + + +-- |Convert an attoparsec parser result to 'WD'. +apResultToWD :: (MonadBaseControl IO wd, FromJSON a) => AP.Result Value -> wd a +apResultToWD p = case p of + Done _ res -> fromJSON' res + Fail _ _ err -> throwIO $ BadJSON err + +-- |Convert an Aeson parser result to 'WD'. +aesonResultToWD :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a +aesonResultToWD r = case r of + Success val -> return val + Error err -> throwIO $ BadJSON err diff --git a/src/Test/WebDriver/Monad.hs b/src/Test/WebDriver/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Monad.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving, + MultiParamTypeClasses #-} +module Test.WebDriver.Monad + ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException + )where + +import Test.WebDriver.Classes +import Test.WebDriver.Commands +import Test.WebDriver.Capabilities +import Test.WebDriver.Internal + +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad (liftM) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Control (MonadBaseControl(..), StM) +import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put) +import Control.Monad.IO.Class (MonadIO) +import Control.Exception.Lifted +import Control.Applicative + +{- |A monadic interface to the WebDriver server. This monad is a simple, strict +layer over 'IO', threading session information between sequential commands +-} +newtype WD a = WD (StateT WDSession IO a) + deriving (Functor, Monad, MonadIO, Applicative) + +instance MonadBase IO WD where + liftBase = WD . liftBase + +instance MonadBaseControl IO WD where + data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a} + + liftBaseWith f = WD $ + liftBaseWith $ \runInBase -> + f (\(WD sT) -> liftM StWD . runInBase $ sT) + + restoreM = WD . restoreM . unStWD + +instance SessionState WD where + getSession = WD get + putSession = WD . put + +instance WebDriver WD where + doCommand method path args = do + r <- mkRequest [] method path args + --liftIO . print $ r + handleHTTPErr r + --liftIO . print . rspBody $ r + handleHTTPResp r + +-- |Executes a 'WD' computation within the 'IO' monad, using the given +-- 'WDSession'. +runWD :: WDSession -> WD a -> IO a +runWD sess (WD wd) = evalStateT wd sess + +-- |Like 'runWD', but automatically creates a session beforehand and closes it +-- afterwards. This is a very common use case. +runSession :: WDSession -> Capabilities -> WD a -> IO a +runSession s caps wd = runWD s $ createSession caps >> wd <* closeSession + +-- |Locally sets a 'WDSession' for use within the given 'WD' action. +-- The state of the outer action is unaffected by this function. +-- This function is useful if you need to work with multiple sessions at once. +withSession :: WDSession -> WD a -> WD a +withSession s' (WD wd) = WD . lift $ evalStateT wd s' + +-- |A finalizer ensuring that the session is always closed at the end of +-- the given 'WD' action, regardless of any exceptions. +finallyClose:: WD a -> WD a +finallyClose wd = closeOnException wd <* closeSession + +-- |A variant of 'finallyClose' that only closes the session when an +-- asynchronous exception is thrown, but otherwise leaves the session open +-- if the action was successful. +closeOnException :: WD a -> WD a +closeOnException wd = wd `onException` closeSession diff --git a/src/Test/WebDriver/Types.hs b/src/Test/WebDriver/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, + TemplateHaskell, OverloadedStrings, ExistentialQuantification, + MultiParamTypeClasses, TypeFamilies, + RecordWildCards + #-} +{-# OPTIONS_HADDOCK not-home #-} +module Test.WebDriver.Types + ( -- * WebDriver sessions + WD(..), WDSession(..), defaultSession, SessionId(..) + -- * Capabilities and configuration + , Capabilities(..), defaultCaps, allCaps + , Platform(..), ProxyType(..) + -- ** Browser-specific configuration + , Browser(..), + -- ** Default settings for browsers + firefox, chrome, ie, opera, iPhone, iPad, android + , LogPref(..) + -- * WebDriver objects and command-specific types + , Element(..) + , WindowHandle(..), currentWindow + , Selector(..) + , JSArg(..) + , FrameSelector(..) + , Cookie(..), mkCookie + , Orientation(..) + , MouseButton(..) + , WebStorageType(..) + -- * Exceptions + , InvalidURL(..), NoSessionId(..), BadJSON(..) + , HTTPStatusUnknown(..), HTTPConnError(..) + , UnknownCommand(..), ServerError(..) + , FailedCommand(..), FailedCommandType(..) + , FailedCommandInfo(..), StackFrame(..) + , mkFailedCommandInfo, failedCommand + ) where + +import Test.WebDriver.Monad +import Test.WebDriver.Classes +import Test.WebDriver.Commands +import Test.WebDriver.Exceptions +import Test.WebDriver.Capabilities + + + + + + + + + + diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,5 +1,5 @@ Name: webdriver -Version: 0.2 +Version: 0.3 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE @@ -9,7 +9,7 @@ Category: Web, Browser, Testing Synopsis: a Haskell client for the Selenium WebDriver protocol Build-type: Simple -Extra-source-files: README.md, TODO, CHANGELOG.md +Extra-source-files: README.md, TODO, CHANGELOG.md, .ghci Description: A Selenium WebDriver client for Haskell. You can use it to automate browser sessions @@ -27,6 +27,7 @@ location: git://github.com/kallisti-dev/hs-webdriver.git library + hs-source-dirs: src ghc-options: -Wall build-depends: base == 4.* , aeson >= 0.4 && < 0.7 @@ -52,13 +53,17 @@ , temporary exposed-modules: Test.WebDriver + Test.WebDriver.Classes + Test.WebDriver.Monad + Test.WebDriver.Exceptions Test.WebDriver.Commands Test.WebDriver.Commands.Wait - Test.WebDriver.Commands.Internal Test.WebDriver.Firefox.Profile + Test.WebDriver.Common.Profile Test.WebDriver.Chrome.Extension + Test.WebDriver.Capabilities Test.WebDriver.Types Test.WebDriver.JSON other-modules: Test.WebDriver.Internal - Test.WebDriver.Types.Internal +