diff --git a/src/Test/WebDriver.hs b/src/Test/WebDriver.hs --- a/src/Test/WebDriver.hs +++ b/src/Test/WebDriver.hs @@ -6,7 +6,7 @@ ( -- * WebDriver sessions WD(..), WDSession(..), defaultSession, SessionId(..) -- * Running WebDriver tests - , runWD, runSession, withSession, finallyClose, closeOnException + , runWD, runSession, withSession, finallyClose, closeOnException, dumpSessionHistory -- * WebDriver commands , module Test.WebDriver.Commands -- * Capabilities and configuration diff --git a/src/Test/WebDriver/Capabilities.hs b/src/Test/WebDriver/Capabilities.hs --- a/src/Test/WebDriver/Capabilities.hs +++ b/src/Test/WebDriver/Capabilities.hs @@ -18,7 +18,7 @@ import Control.Applicative import Control.Exception.Lifted (throw) - + {- |A structure describing the capabilities of a session. This record serves dual roles. @@ -147,7 +147,7 @@ , "acceptSslCerts" .= acceptSSLCerts , "nativeEvents" .= nativeEvents , "unexpectedAlertBehavior" .= unexpectedAlertBehavior - ] + ] ++ browserInfo ++ additionalCaps where @@ -226,15 +226,15 @@ <*> b "nativeEvents" <*> opt "unexpectedAlertBehaviour" Nothing <*> pure (additionalCapabilities browser) - - where --some helpful JSON accessor shorthands + + where --some helpful JSON accessor shorthands 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 - + -- produce additionalCaps by removing known capabilities from the JSON object additionalCapabilities = HM.toList . foldr HM.delete o . knownCapabilities @@ -253,9 +253,9 @@ ,"logFile", "logLevel", "host", "extractPath", "silent", "forceCreateProcess", "internetExplorerSwitches"] Opera {} -> ["opera.binary", "opera.product", "opera.no_quit", "opera.autostart", "opera.idle", "opera.display" ,"opera.launcher", "opera.port", "opera.host", "opera.arguments", "opera.logging.file", "opera.logging.level"] - _ -> [] + _ -> [] getBrowserCaps browser = - case browser of + case browser of Firefox {} -> Firefox <$> opt "firefox_profile" Nothing <*> opt "loggingPrefs" def <*> opt "firefox_binary" Nothing @@ -284,14 +284,14 @@ <*> opt "opera.autostart" True <*> opt "opera.idle" False <*> opt "opera.display" Nothing - <*> opt "opera.launcher" Nothing + <*> opt "opera.launcher" Nothing <*> opt "opera.port" (Just 0) <*> opt "opera.host" Nothing <*> opt "opera.arguments" Nothing <*> opt "opera.logging.file" Nothing <*> opt "opera.logging.level" def _ -> return browser - + parseJSON v = typeMismatch "Capabilities" v -- |This constructor simultaneously specifies which browser the session will @@ -334,30 +334,30 @@ -- |Indicates whether to skip the check that the browser's zoom -- level is set to 100%. Value is set to false by default. , ieIgnoreZoomSetting :: Bool - -- |Allows the user to specify the initial URL loaded when IE + -- |Allows the user to specify the initial URL loaded when IE -- starts. Intended to be used with ignoreProtectedModeSettings - -- to allow the user to initialize IE in the proper Protected Mode + -- to allow the user to initialize IE in the proper Protected Mode -- zone. Using this capability may cause browser instability or -- flaky and unresponsive code. Only \"best effort\" support is -- provided when using this capability. , ieInitialBrowserUrl :: Maybe Text - -- |Allows the user to specify whether elements are scrolled into - -- the viewport for interaction to align with the top or bottom - -- of the viewport. The default value is to align with the top of + -- |Allows the user to specify whether elements are scrolled into + -- the viewport for interaction to align with the top or bottom + -- of the viewport. The default value is to align with the top of -- the viewport. , ieElementScrollBehavior :: IEElementScrollBehavior - -- |Determines whether persistent hovering is enabled (true by - -- default). Persistent hovering is achieved by continuously firing - -- mouse over events at the last location the mouse cursor has been + -- |Determines whether persistent hovering is enabled (true by + -- default). Persistent hovering is achieved by continuously firing + -- mouse over events at the last location the mouse cursor has been -- moved to. , ieEnablePersistentHover :: Bool - -- |Determines whether the driver should attempt to remove obsolete - -- elements from the element cache on page navigation (true by + -- |Determines whether the driver should attempt to remove obsolete + -- elements from the element cache on page navigation (true by -- default). This is to help manage the IE driver's memory footprint -- , removing references to invalid elements. , ieEnableElementCacheCleanup :: Bool - -- |Determines whether to require that the IE window have focus - -- before performing any user interaction operations (mouse or + -- |Determines whether to require that the IE window have focus + -- before performing any user interaction operations (mouse or -- keyboard events). This capability is false by default, but -- delivers much more accurate native events interactions. , ieRequireWindowFocus :: Bool @@ -365,26 +365,26 @@ -- locate and attach to a newly opened instance of Internet Explorer -- . The default is zero, which indicates waiting indefinitely. , ieBrowserAttachTimeout :: Integer - -- |The path to file where server should write log messages to. + -- |The path to file where server should write log messages to. -- By default it writes to stdout. , ieLogFile :: Maybe FilePath -- |The log level used by the server. Defaults to 'IELogFatal' , ieLogLevel :: IELogLevel - -- |The address of the host adapter on which the server will listen + -- |The address of the host adapter on which the server will listen -- for commands. , ieHost :: Maybe Text - -- |The path to the directory used to extract supporting files used + -- |The path to the directory used to extract supporting files used -- by the server. Defaults to the TEMP directory if not specified. , ieExtractPath :: Maybe Text -- |Suppresses diagnostic output when the server is started. , ieSilent :: Bool - -- |Forces launching Internet Explorer using the CreateProcess API. + -- |Forces launching Internet Explorer using the CreateProcess API. -- If this option is not specified, IE is launched using the - -- IELaunchURL, if it is available. For IE 8 and above, this option + -- IELaunchURL, if it is available. For IE 8 and above, this option -- requires the TabProcGrowth registry value to be set to 0. , ieForceCreateProcess :: Bool - -- |Specifies command-line switches with which to launch Internet - -- Explorer. This is only valid when used with the + -- |Specifies command-line switches with which to launch Internet + -- Explorer. This is only valid when used with the -- forceCreateProcess. , ieSwitches :: Maybe Text } @@ -477,7 +477,7 @@ chrome :: Browser chrome = Chrome Nothing Nothing [] [] --- |Default IE settings. See the 'IE' constructor for more details on +-- |Default IE settings. See the 'IE' constructor for more details on -- individual defaults ie :: Browser ie = IE { ieIgnoreProtectedModeSettings = True @@ -600,21 +600,21 @@ ,"httpProxy" .= http ] -data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert +data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert deriving (Bounded, Enum, Eq, Ord, Read, Show) - + instance ToJSON UnexpectedAlertBehavior where toJSON AcceptAlert = String "accept" toJSON DismissAlert = String "dismiss" toJSON IgnoreAlert = String "ignore" - + instance FromJSON UnexpectedAlertBehavior where - parseJSON (String s) = + parseJSON (String s) = return $ case s of "accept" -> AcceptAlert "dismiss" -> DismissAlert "ignore" -> IgnoreAlert - err -> throw . BadJSON + err -> throw . BadJSON $ "Invalid string value for UnexpectedAlertBehavior: " ++ show err parseJSON v = typeMismatch "UnexpectedAlertBehavior" v @@ -651,8 +651,8 @@ "ALL" -> LogAll _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s parseJSON other = typeMismatch "LogLevel" other - + -- |Logging levels for Internet Explorer data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError | IELogFatal @@ -685,19 +685,19 @@ -- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior') data IEElementScrollBehavior = AlignTop | AlignBottom deriving (Eq, Ord, Show, Read, Enum, Bounded) - -instance Default IEElementScrollBehavior where + +instance Default IEElementScrollBehavior where def = AlignTop - + instance ToJSON IEElementScrollBehavior where toJSON AlignTop = toJSON (0 :: Int) toJSON AlignBottom = toJSON (1 :: Int) - + instance FromJSON IEElementScrollBehavior where parseJSON v = do n <- parseJSON v - case n :: Integer of + case n :: Integer of 0 -> return AlignTop 1 -> return AlignBottom _ -> fail $ "Invalid integer for IEElementScrollBehavior: " ++ show n - + diff --git a/src/Test/WebDriver/Classes.hs b/src/Test/WebDriver/Classes.hs --- a/src/Test/WebDriver/Classes.hs +++ b/src/Test/WebDriver/Classes.hs @@ -6,13 +6,14 @@ -- * SessionState class SessionState(..), modifySession -- ** WebDriver sessions - , WDSession(..), SessionId(..), defaultSession + , WDSession(..), lastHTTPRequest, SessionId(..), defaultSession ) where --import Test.WebDriver.Internal import Data.Aeson +import Data.Maybe import Network.HTTP (RequestMethod(..)) -import Network.HTTP.Base (Request) +import Network.HTTP.Base (Request, Response) import Data.ByteString.Lazy (ByteString) import Data.Text (Text) @@ -52,7 +53,7 @@ -> Text -- ^URL of request -> a -- ^JSON parameters passed in the body -- of the request. Note that, as a special case, - -- anything that converts to Data.Aeson.Null will + -- anything that converts to Data.Aeson.Null will -- result in an empty request body. -> wd b -- ^The JSON result of the HTTP request. @@ -79,16 +80,28 @@ -- and closed automatically with -- 'Test.WebDriver.runSession' , wdSessId :: Maybe SessionId - -- |The last HTTP request issued by this session, if any. - , lastHTTPRequest :: Maybe (Request ByteString) + -- |The complete history of HTTP requests and + -- responses (updated in 'doCommand', most recent + -- first). + , wdSessHist :: [(Request ByteString, Response ByteString)] + -- |If 'wdKeepSessHist' is 'True', 'wdSessHist' + -- contains the full session history. + -- Otherwise, only the last request/response + -- pair is stored (O(1) heap consumption). + , wdKeepSessHist :: Bool } deriving (Show) +-- |The last HTTP request issued by this session, if any. +lastHTTPRequest :: WDSession -> Maybe (Request ByteString) +lastHTTPRequest = fmap fst . listToMaybe . wdSessHist + instance Default WDSession where def = WDSession { wdHost = "127.0.0.1" , wdPort = 4444 , wdBasePath = "/wd/hub" , wdSessId = Nothing - , lastHTTPRequest = Nothing + , wdSessHist = [] + , wdKeepSessHist = False } {- |A default session connects to localhost on port 4444, and hasn't been diff --git a/src/Test/WebDriver/Commands.hs b/src/Test/WebDriver/Commands.hs --- a/src/Test/WebDriver/Commands.hs +++ b/src/Test/WebDriver/Commands.hs @@ -623,30 +623,30 @@ -- to the given element. touchScrollFrom :: WebDriver wd => (Int, Int) -> Element -> wd () touchScrollFrom (x, y) (Element e) = - noReturn + noReturn . 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) = +touchDoubleClick (Element e) = noReturn . doSessCommand POST "/touch/doubleclick" . single "element" $ e -- |Emulate a long click on a touch device. touchLongClick :: WebDriver wd => Element -> wd () -touchLongClick (Element e) = - noReturn +touchLongClick (Element e) = + noReturn . 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 = - noReturn +touchFlick = + noReturn . doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed") @@ -672,7 +672,7 @@ -- |Set the current geographical location of the device. setLocation :: WebDriver wd => (Int, Int, Int) -> wd () -setLocation = noReturn . doSessCommand POST "/location" +setLocation = noReturn . doSessCommand POST "/location" . triple ("latitude", "longitude", "altitude") @@ -744,9 +744,9 @@ serverStatus = doCommand GET "/status" Null -- |A record that represents a single log entry. -data LogEntry = - LogEntry { logTime :: Integer -- ^ timestamp for the log entry. The standard - -- does not specify the epoch or the unit of +data LogEntry = + LogEntry { logTime :: Integer -- ^ timestamp for the log entry. The standard + -- does not specify the epoch or the unit of -- time. , logLevel :: LogLevel -- ^ log verbosity level , logMsg :: Text @@ -787,7 +787,7 @@ 4 -> return UpdateReady 5 -> return Obsolete err -> fail $ "Invalid JSON for ApplicationCacheStatus: " ++ show err - + getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus getApplicationCacheStatus = doSessCommand GET "/application_cache/status" Null diff --git a/src/Test/WebDriver/Commands/Wait.hs b/src/Test/WebDriver/Commands/Wait.hs --- a/src/Test/WebDriver/Commands/Wait.hs +++ b/src/Test/WebDriver/Commands/Wait.hs @@ -99,14 +99,14 @@ wait' :: SessionState m => ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime - where + where timeout = realToFrac t waitLoop startTime = handler retry wd where retry why = do now <- liftBase getCurrentTime - if diffUTCTime now startTime >= timeout - then + if diffUTCTime now startTime >= timeout + then failedCommand Timeout $ "wait': explicit wait timed out (" ++ why ++ ")." else do liftBase . threadDelay $ waitAmnt diff --git a/src/Test/WebDriver/Firefox/Profile.hs b/src/Test/WebDriver/Firefox/Profile.hs --- a/src/Test/WebDriver/Firefox/Profile.hs +++ b/src/Test/WebDriver/Firefox/Profile.hs @@ -197,7 +197,7 @@ -- |Convenience function to load an existing Firefox profile from disk, apply -- a handler function, and then prepare the result for network transmission. --- +-- -- NOTE: like 'prepareProfile', the same caveat about large profiles applies. prepareLoadedProfile :: MonadBaseControl IO m => FilePath diff --git a/src/Test/WebDriver/Internal.hs b/src/Test/WebDriver/Internal.hs --- a/src/Test/WebDriver/Internal.hs +++ b/src/Test/WebDriver/Internal.hs @@ -39,8 +39,8 @@ -- |Take a URL path and construct a full URL using the current session state mkWDUri :: (SessionState s) => String -> s URI -mkWDUri wdPath = do - WDSession{wdHost = host, +mkWDUri wdPath = do + WDSession{wdHost = host, wdPort = port, wdBasePath = basePath } <- getSession @@ -75,18 +75,18 @@ -sendHTTPRequest :: SessionState s => Request ByteString -> s (Response ByteString) +sendHTTPRequest :: SessionState s => Request ByteString -> s (Response ByteString) sendHTTPRequest req = do - r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return - modifySession $ \s -> s {lastHTTPRequest = Just req} -- update lastHTTPRequest field - return r + res <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return + modifySession $ \s -> s {wdSessHist = (req, res) : if wdKeepSessHist s then wdSessHist s else []} -- update httpScript field + return res handleHTTPErr :: SessionState s => Response ByteString -> s () handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = case code of (4,_,_) -> do - lastReq <- lastHTTPRequest <$> getSession - throwIO . UnknownCommand . maybe reason show + lastReq <- lastHTTPRequest <$> getSession + throwIO . UnknownCommand . maybe reason show $ lastReq (5,_,_) -> case findHeader HdrContentType r of @@ -98,7 +98,7 @@ err (ServerError . ("Missing content type. Server response: "++)) (2,_,_) -> return () - (3,0,x) | x `elem` [2,3] + (3,0,x) | x `elem` [2,3] -> return () _ -> err (HTTPStatusUnknown code) where @@ -110,7 +110,7 @@ (2,0,4) -> noReturn (3,0,x) | x `elem` [2,3] -> - case findHeader HdrLocation resp of + case findHeader HdrLocation resp of Nothing -> throwIO . HTTPStatusUnknown code $ (LBS.unpack body) Just loc -> do @@ -127,7 +127,7 @@ -- if our monad has an uninitialized session ID, initialize it from the response object (Nothing, _) -> putSession sess { wdSessId = sessId' } -- if the response ID doesn't match our local ID, throw an error. - (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId' + (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId' ++ ") does not match local session ID (" ++ show sessId ++ ")" -- otherwise nothing needs to be done _ -> return () diff --git a/src/Test/WebDriver/Monad.hs b/src/Test/WebDriver/Monad.hs --- a/src/Test/WebDriver/Monad.hs +++ b/src/Test/WebDriver/Monad.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} module Test.WebDriver.Monad - ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException + ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException, dumpSessionHistory )where import Test.WebDriver.Classes @@ -11,6 +11,7 @@ import Control.Monad.Base (MonadBase, liftBase) import Control.Monad (liftM) +import Control.Monad.IO.Class import Control.Monad.Trans (lift) import Control.Monad.Trans.Control (MonadBaseControl(..), StM) import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put) @@ -74,3 +75,14 @@ -- if the action was successful. closeOnException :: WebDriver wd => wd a -> wd a closeOnException wd = wd `onException` closeSession + +-- |Can be called before 'closeOnException' to get more information on +-- stdout. about what was going wrong. (Note that the 'Show' +-- instances in package HTTP are not very generous with the 'Response' +-- and 'Request' type. You might want to write your own variant of +-- this function.) +dumpSessionHistory :: (MonadIO wd, WebDriver wd) => wd a -> wd a +dumpSessionHistory wd = do + v <- wd + getSession >>= liftIO . print . wdSessHist + return v diff --git a/src/Test/WebDriver/Utils.hs b/src/Test/WebDriver/Utils.hs --- a/src/Test/WebDriver/Utils.hs +++ b/src/Test/WebDriver/Utils.hs @@ -5,4 +5,4 @@ import qualified Network.HTTP.Base as HTTP urlEncode :: Text -> Text -urlEncode = T.pack . HTTP.urlEncode . T.unpack +urlEncode = T.pack . HTTP.urlEncode . T.unpack diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,5 +1,5 @@ Name: webdriver -Version: 0.5.4 +Version: 0.5.5 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE