packages feed

webdriver 0.7 → 0.8

raw patch · 18 files changed

+264/−126 lines, 18 filesdep +data-default-classdep −data-defaultdep −mtldep −paralleldep ~aesondep ~attoparsecdep ~base

Dependencies added: data-default-class

Dependencies removed: data-default, mtl, parallel

Dependency ranges changed: aeson, attoparsec, base, bytestring

Files

CHANGELOG.md view
@@ -1,5 +1,45 @@ #Change Log +##0.8++###Command changes+* All commands that previously accepted a list parameter now accepts any instance of `Foldable` instead.++++###Overloadable configuration+It is now possible to define custom configuration types that can be used to initialize webdriver sessions.++`runSession` now has the following type:+```+  runSession :: WebDriverConfig conf => conf -> WD a -> IO a+```+And the typeclass to create new config types looks like this:++```hs+  -- |Class of types that can configure a WebDriver session.+  class WebDriverConfig c where+    -- |Produces a 'Capabilities' from the given configuration.+    mkCaps :: MonadBase IO m => c -> m Capabilities++    -- |Produces a 'WDSession' from the given configuration.+    mkSession :: MonadBase IO m => c -> m WDSession+```++Of course you can still use `WDConfig`, as it now an instance of `WebDriverConfig`.++###Reworked custom HTTP headers interface+* Support for custom request headers was added rather hastily, resulting in several functions having explicit RequestHeaders parameters. The interface has been reworked now so that custom request headers are stored inside `WDSession` and explicit `RequestHeaders` parameters have been removed.+* There's also now a distinction in configuration between `wdAuthHeaders` which are used only during initial session creation, and `wdRequestHeaders`, which are used with all other HTTP requests+* Two new utility functions were added to make working with custom HTTP headers easier: `withRequestHeaders` and `withAuthHeaders`++###Clean-up and dependency changes+* Removed a whole mess of unusued import and deprecation warnings when building with GHC 7.10+* We now enforce an attoparsec lower bound of 0.10 (there was no lower bound before)+* The unnecessary dependency on mtl is now removed.+* Added some monad transformer instances for WebDriver and WDSessionState that were mysteriously missing: strict WriterT, ReaderT, ListT+* data-default dependency was changed to data-default-class+ ##0.7  Because this is a fairly major update, changes have been described in detail and organized into categories. Most of the potentially breaking changes are to the "intermediate" API that might affect library code or advanced applications; changes that are not entirely "user-facing" but also not quite "internal".
src/Test/WebDriver.hs view
@@ -6,7 +6,7 @@   ( -- * WebDriver monad     WD(..)      -- * Running WebDriver commands-  , runWD, runSession, withSession+  , runSession, withSession, runWD     -- * WebDriver configuration   , WDConfig(..), defaultConfig     -- ** Configuration helper functions@@ -15,6 +15,8 @@   , useBrowser, useProxy, useVersion, usePlatform      -- ** Session history configuration   , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory+    -- ** HTTP request header utilities+  , withRequestHeaders, withAuthHeaders     -- * WebDriver commands   , module Test.WebDriver.Commands     -- * Capabilities (advanced configuration)
src/Test/WebDriver/Capabilities.hs view
@@ -11,7 +11,7 @@ import qualified Data.HashMap.Strict as HM (delete, toList)  import Data.Text (Text, toLower, toUpper)-import Data.Default (Default(..))+import Data.Default.Class (Default(..)) import Data.Word (Word16) import Data.Maybe (fromMaybe, catMaybes) import Data.String (fromString)@@ -19,9 +19,14 @@ import Control.Applicative import Control.Exception.Lifted (throw) +import Prelude -- hides some "unused import" warnings+ -- |A typeclass for readable 'Capabilities' class GetCapabilities t where   getCaps :: t -> Capabilities++instance GetCapabilities Capabilities where+  getCaps = id  -- |A typeclass for writable 'Capabilities' class SetCapabilities t where
src/Test/WebDriver/Chrome/Extension.hs view
@@ -13,6 +13,8 @@ import Control.Applicative import Control.Monad.Base +import Prelude -- hides some "unused import" warnings+ -- |An opaque type representing a Google Chrome extension. Values of this type -- are passed to the 'Test.Webdriver.chromeExtensions' field. newtype ChromeExtension = ChromeExtension Text
src/Test/WebDriver/Class.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts,+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, CPP,              GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds #-}+#ifndef CABAL_BUILD_DEVELOPER+{-# OPTIONS_GHC  -fno-warn-warnings-deprecations #-}+#endif module Test.WebDriver.Class        ( -- * WebDriver class          WebDriver(..), Method, methodDelete, methodGet, methodPost,@@ -10,22 +13,20 @@ import Data.Text (Text)  import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)-import Network.HTTP.Types.Header (RequestHeaders) +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.Identity-import Control.Monad.List-import Control.Monad.Reader-import Control.Monad.Error+import Control.Monad.Trans.List+import Control.Monad.Trans.Reader+import Control.Monad.Trans.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 Control.Monad.Trans.Writer.Strict as SW+import Control.Monad.Trans.Writer.Lazy as LW+import Control.Monad.Trans.State.Strict as SS+import Control.Monad.Trans.State.Lazy as LS+import Control.Monad.Trans.RWS.Strict as SRWS+import Control.Monad.Trans.RWS.Lazy as LRWS   -- |A class for monads that can handle wire protocol requests. This is the@@ -34,8 +35,7 @@ -- <http://code.google.com/p/selenium/wiki/JsonWireProtocol> class (WDSessionStateControl wd) => WebDriver wd where   doCommand :: (ToJSON a, FromJSON b) =>-                RequestHeaders -- ^Additional headers-                -> Method      -- ^HTTP request method+                   Method      -- ^HTTP request method                 -> Text        -- ^URL of request                 -> a           -- ^JSON parameters passed in the body                                -- of the request. Note that, as a special case,@@ -44,33 +44,36 @@                 -> wd b        -- ^The JSON result of the HTTP request.  instance WebDriver wd => WebDriver (SS.StateT s wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)  instance WebDriver wd => WebDriver (LS.StateT s wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)   instance WebDriver wd => WebDriver (MaybeT wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)-+  doCommand rm t a = lift (doCommand rm t a)  instance WebDriver wd => WebDriver (IdentityT wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a) +instance WebDriver wd => WebDriver (ListT wd) where+  doCommand rm t a = lift (doCommand rm t a)  instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a) +instance (Monoid w, WebDriver wd) => WebDriver (SW.WriterT w wd) where+  doCommand rm t a = lift (doCommand rm t a)  instance WebDriver wd => WebDriver (ReaderT r wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)  instance (Error e, WebDriver wd) => WebDriver (ErrorT e wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)   instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)  instance (Monoid w, WebDriver wd) => WebDriver (LRWS.RWST r w s wd) where-  doCommand rh rm t a = lift (doCommand rh rm t a)+  doCommand rm t a = lift (doCommand rm t a)
src/Test/WebDriver/Commands.hs view
@@ -91,10 +91,10 @@ import Network.URI hiding (path)  -- suppresses warnings import Codec.Archive.Zip import qualified Data.Text.Lazy.Encoding as TL-import Network.HTTP.Types.Header (RequestHeaders) +import Control.Monad import Control.Applicative-import Control.Monad.State.Strict+--import Control.Monad.State.Strict import Control.Monad.Base import Control.Exception (SomeException) import Control.Exception.Lifted (throwIO, handle)@@ -102,8 +102,11 @@ import Data.Word import Data.String (fromString) import Data.Maybe+import Data.Foldable import qualified Data.Char as C +import Prelude -- hides some "unused import" warnings+ -- |Convenience function to handle webdriver commands with no return value noReturn :: WebDriver wd => wd NoReturn -> wd () noReturn = void@@ -112,17 +115,19 @@ ignoreReturn :: WebDriver wd => wd Value -> wd () ignoreReturn = void --- |Create a new session with the given 'Capabilities'.-createSession :: WebDriver wd => RequestHeaders -> Capabilities -> wd WDSession-createSession headers caps = do-  ignoreReturn . doCommand headers methodPost "/session" . single "desiredCapabilities" $ caps+-- |Create a new session with the given 'Capabilities'. The returned session becomes the \"current session\" for this action. +-- +-- Note: if you're using 'runSession' to run your WebDriver commands, you don't need to call this explicitly.+createSession :: WebDriver wd => Capabilities -> wd WDSession+createSession caps = do+  ignoreReturn . withAuthHeaders . doCommand methodPost "/session" . single "desiredCapabilities" $ caps   getSession  -- |Retrieve a list of active sessions and their 'Capabilities'.-sessions :: WebDriver wd => RequestHeaders -> wd [(SessionId, Capabilities)]-sessions headers = do-  objs <- doCommand headers methodGet "/sessions" Null-  forM objs $ parsePair "id" "capabilities" "sessions"+sessions :: WebDriver wd => wd [(SessionId, Capabilities)]+sessions = do+  objs <- doCommand methodGet "/sessions" Null+  mapM (parsePair "id" "capabilities" "sessions") objs  -- |Get the actual server-side 'Capabilities' of the current session. getActualCaps :: WebDriver wd => wd Capabilities@@ -194,7 +199,7 @@ 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+The first parameter defines a sequence of 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.@@ -205,7 +210,7 @@ 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 :: (Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a executeJS a s = fromJSON' =<< getResult   where     getResult = doSessCommand methodPost "/execute" . pair ("args", "script") $ (a,s)@@ -217,7 +222,7 @@ 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 :: (Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a) asyncJS a s = handle timeout $ Just <$> (fromJSON' =<< getResult)   where     getResult = doSessCommand methodPost "/execute_async" . pair ("args", "script")@@ -234,7 +239,7 @@ screenshotBase64 :: WebDriver wd => wd LBS.ByteString screenshotBase64 = TL.encodeUtf8 <$> doSessCommand methodGet "/screenshot" Null -availableIMEEngines :: WebDriver wd => wd [Text]+availableIMEEngines :: WebDriver wd => wd Text availableIMEEngines = doSessCommand methodGet "/ime/available_engines" Null  activeIMEEngine :: WebDriver wd => wd Text@@ -411,7 +416,7 @@ findElem = doSessCommand methodPost "/element"  -- |Find all elements on the page matching the given selector.-findElems :: WebDriver wd => Selector -> wd [Element]+findElems :: WebDriver wd => Selector -> wd Element findElems = doSessCommand methodPost "/elements"  -- |Return the element that currently has focus.@@ -423,7 +428,7 @@ findElemFrom e = doElemCommand methodPost e "/element"  -- |Find all elements matching a selector, using the given element as root.-findElemsFrom :: WebDriver wd => Element -> Selector -> wd [Element]+findElemsFrom :: WebDriver wd => Element -> Selector -> wd Element findElemsFrom e = doElemCommand methodPost e "/elements"  -- |Describe the element. Returns a JSON object whose meaning is currently@@ -736,8 +741,8 @@ -- |Get information from the server as a JSON 'Object'. For more information -- about this object see -- <http://code.google.com/p/selenium/wiki/JsonWireProtocol#/status>-serverStatus :: (WebDriver wd) => RequestHeaders -> wd Value   -- todo: make this a record type-serverStatus headers = doCommand headers methodGet "/status" Null+serverStatus :: (WebDriver wd) => wd Value   -- todo: make this a record type+serverStatus = doCommand methodGet "/status" Null  -- |A record that represents a single log entry. data LogEntry =
src/Test/WebDriver/Commands/Internal.hs view
@@ -26,9 +26,11 @@ import qualified Data.Text as T import Control.Exception.Lifted import Data.Typeable-import Data.Default+import Data.Default.Class import Control.Applicative +import Prelude -- hides some "unused import" warnings+ {- |An opaque identifier for a web page element. -} newtype Element = Element Text                   deriving (Eq, Ord, Show, Read)@@ -73,7 +75,7 @@         where           msg = "doSessCommand: No session ID found for relative URL "                 ++ show path-      Just (SessionId sId) -> doCommand [] method+      Just (SessionId sId) -> doCommand method                               (T.concat ["/session/", urlEncode sId, path]) args  -- |A wrapper around 'doSessCommand' to create element URLs.
src/Test/WebDriver/Commands/Wait.hs view
@@ -25,10 +25,13 @@  import Data.Time.Clock import Data.Typeable+import Data.Foldable import Data.Text (Text)  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch)+#else+import Prelude -- hides some "redundant import" warnings #endif  instance Exception ExpectFailed@@ -51,13 +54,13 @@  -- |Apply a monadic 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+expectAny :: (Foldable f, MonadBaseControl IO m) => (a -> m Bool) -> f a -> m ()+expectAny p xs = expect . or =<< mapM p (toList xs)  -- |Apply a monadic 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+expectAll :: (Foldable f, MonadBaseControl IO m) => (a -> m Bool) -> f a -> m ()+expectAll p xs = expect . and =<< mapM p (toList xs)  -- | 'expect' the given 'Element' to not be stale and returns it expectNotStale :: WebDriver wd => Element -> wd Element
src/Test/WebDriver/Common/Profile.hs view
@@ -54,6 +54,8 @@ import Control.Applicative import Control.Monad.Base +import Prelude -- hides some "unused import" warnings+ -- |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 profiles; when a distinction
src/Test/WebDriver/Config.hs view
@@ -6,13 +6,18 @@     , modifyCaps, useBrowser, useVersion, usePlatform, useProxy     -- * SessionHistoryConfig options     , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory+    -- * Overloadable configuration+    , WebDriverConfig(..)     ) where import Test.WebDriver.Capabilities-import Test.WebDriver.Session.History+import Test.WebDriver.Session -import Data.Default (Default, def)+import Data.Default.Class (Default(..))+import Data.String (fromString) -import Network.HTTP.Client (Manager)+import Control.Monad.Base++import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) import Network.HTTP.Types (RequestHeaders)  -- |WebDriver session configuration@@ -22,14 +27,17 @@       wdHost :: String      -- |Port number of the server (default 4444)     , wdPort :: Int-     -- |Additional request headers to send to the server during session creation (default [])-    , wdRequestHeaders :: RequestHeaders      -- |Capabilities to use for this session     , wdCapabilities :: Capabilities-     -- |Specifies behavior of HTTP request/response history. By default we use 'unlimitedHistory'.-    , wdHistoryConfig :: SessionHistoryConfig      -- |Base path for all API requests (default "\/wd\/hub")     , wdBasePath :: String+    -- |Custom request headers to add to every HTTP request.+    , wdRequestHeaders :: RequestHeaders+    -- |Custom request headers to add *only* to session creation requests. This is usually done+    --  when a WebDriver server requires HTTP auth.+    , wdAuthHeaders :: RequestHeaders+     -- |Specifies behavior of HTTP request/response history. By default we use 'unlimitedHistory'.+    , wdHistoryConfig :: SessionHistoryConfig      -- |Use the given http-client 'Manager' instead of automatically creating one.     , wdHTTPManager :: Maybe Manager      -- |Number of times to retry a HTTP request if it times out (default 0)@@ -42,26 +50,12 @@ instance SetCapabilities WDConfig where   setCaps caps conf = conf { wdCapabilities = caps } --- |A function used by 'wdHistoryConfig' to append new entries to session history.-type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]---- |No session history is saved.-noHistory :: SessionHistoryConfig-noHistory _ _ = []---- |Keep unlimited history-unlimitedHistory :: SessionHistoryConfig-unlimitedHistory = (:)---- |Saves only the most recent history-onlyMostRecentHistory :: SessionHistoryConfig-onlyMostRecentHistory h _ = [h]- instance Default WDConfig where     def = WDConfig {       wdHost              = "127.0.0.1"     , wdPort              = 4444     , wdRequestHeaders    = []+    , wdAuthHeaders       = []     , wdCapabilities      = def     , wdHistoryConfig     = unlimitedHistory     , wdBasePath          = "/wd/hub"@@ -74,3 +68,29 @@ polymorphic type. -} defaultConfig :: WDConfig defaultConfig = def++-- |Class of types that can configure a WebDriver session.+class WebDriverConfig c where+    -- |Produces a 'Capabilities' from the given configuration.+    mkCaps :: MonadBase IO m => c -> m Capabilities++    -- |Produces a 'WDSession' from the given configuration.+    mkSession :: MonadBase IO m => c -> m WDSession++instance WebDriverConfig WDConfig where+    mkCaps = return . getCaps++    mkSession WDConfig{..} = do+      manager <- maybe createManager return wdHTTPManager+      return WDSession { wdSessHost = fromString $ wdHost+                       , wdSessPort = wdPort+                       , wdSessRequestHeaders = wdRequestHeaders+                       , wdSessAuthHeaders = wdAuthHeaders+                       , wdSessBasePath = fromString $ wdBasePath+                       , wdSessId = Nothing+                       , wdSessHist = []+                       , wdSessHistUpdate = wdHistoryConfig+                       , wdSessHTTPManager = manager+                       , wdSessHTTPRetryCount = wdHTTPRetryCount }+      where+        createManager = liftBase $ newManager defaultManagerSettings
src/Test/WebDriver/Exceptions/Internal.hs view
@@ -21,7 +21,9 @@  import Data.Typeable (Typeable) import Data.Maybe (fromMaybe)-import Data.Word (Word)+import Data.Word++import Prelude -- hides some "unused import" warnings  instance Exception InvalidURL -- |An invalid URL was given
src/Test/WebDriver/Firefox/Profile.hs view
@@ -29,7 +29,7 @@ import Test.WebDriver.Common.Profile import Data.Aeson import Data.Aeson.Parser (jstring, value')-import Data.Attoparsec.Char8 as AP+import Data.Attoparsec.ByteString.Char8 as AP import qualified Data.HashMap.Strict as HM import Data.Text (Text) import Data.ByteString as BS (readFile)
src/Test/WebDriver/Internal.hs view
@@ -33,12 +33,14 @@  import Data.String (fromString) import Data.Word (Word8)-import Data.Default+import Data.Default.Class +import Prelude -- hides some "unused import" warnings+ -- |Constructs an HTTP 'Request' value when given a list of headers, HTTP request method, and URL fragment mkRequest :: (WDSessionState s, ToJSON a) =>-             RequestHeaders -> Method -> Text -> a -> s Request-mkRequest headers meth wdPath args = do+             Method -> Text -> a -> s Request+mkRequest meth wdPath args = do   WDSession {..} <- getSession   let body = case toJSON args of         Null  -> ""   --passing Null as the argument indicates no request body@@ -47,9 +49,10 @@              , port = wdSessPort              , path = wdSessBasePath `BS.append`  TE.encodeUtf8 wdPath              , requestBody = RequestBodyLBS body-             , requestHeaders = headers ++ [ (hAccept, "application/json;charset=UTF-8")-                                           , (hContentType, "application/json;charset=UTF-8")-                                           , (hContentLength, fromString . show . LBS.length $ body) ]+             , requestHeaders = wdSessRequestHeaders+                                ++ [ (hAccept, "application/json;charset=UTF-8")+                                   , (hContentType, "application/json;charset=UTF-8")+                                   , (hContentLength, fromString . show . LBS.length $ body) ]              , checkStatus = \_ _ _ -> Nothing -- all status codes handled by getJSONResult              , method = meth }
src/Test/WebDriver/JSON.hs view
@@ -45,6 +45,8 @@ import Data.String import Data.Typeable +import Prelude -- hides some "unused import" warnings+ instance Exception BadJSON -- |An error occured when parsing a JSON value. newtype BadJSON = BadJSON String
src/Test/WebDriver/Monad.hs view
@@ -11,19 +11,22 @@ import Test.WebDriver.Internal  import Control.Monad.Base (MonadBase, liftBase)-import Control.Monad.Reader+import Control.Monad.IO.Class+import Control.Monad.Fix import Control.Monad.Trans.Control (MonadBaseControl(..), StM)-import Control.Monad.State.Strict (StateT, evalStateT, get, put)+import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put) --import Control.Monad.IO.Class (MonadIO) import Control.Exception.Lifted import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Applicative +import Prelude -- hides some "unused import" warnings + {- |A state monad for WebDriver commands. -} newtype WD a = WD (StateT WDSession IO a)-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch)+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadFix)  instance MonadBase IO WD where   liftBase = WD . liftBase@@ -52,8 +55,8 @@   putSession = WD . put  instance WebDriver WD where-  doCommand headers method path args =-    mkRequest headers method path args+  doCommand method path args =+    mkRequest method path args     >>= sendHTTPRequest     >>= either throwIO return     >>= getJSONResult@@ -70,10 +73,11 @@ -- Example: -- -- >    runSessionThenClose action = runSession myConfig . finallyClose $ action-runSession :: WDConfig -> WD a -> IO a+runSession :: WebDriverConfig conf => conf -> WD a -> IO a runSession conf wd = do   sess <- mkSession conf-  runWD sess $ createSession (wdRequestHeaders conf) (wdCapabilities conf) >> wd+  caps <- mkCaps conf+  runWD sess $ createSession caps >> wd  -- |A finalizer ensuring that the session is always closed at the end of -- the given 'WD' action, regardless of any exceptions.
src/Test/WebDriver/Session.hs view
@@ -1,44 +1,53 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables,-             GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds #-}+             GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds, CPP #-}++#ifndef CABAL_BUILD_DEVELOPER+{-# OPTIONS_GHC  -fno-warn-warnings-deprecations #-}+#endif+ module Test.WebDriver.Session   ( -- * WDSessionState class     WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession     -- ** WebDriver sessions-  , WDSession(..), mkSession, mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)+  , WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)     -- * SessionHistoryConfig options   , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory+    -- * Using custom HTTP request headers+  , withRequestHeaders, withAuthHeaders   ) where -import Test.WebDriver.Config import Test.WebDriver.Session.History  import Data.Aeson import Data.ByteString as BS(ByteString)  import Data.Text (Text) import Data.Maybe (listToMaybe)-import Data.String (fromString)  import Control.Applicative import Control.Monad.Base+import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Maybe import Control.Monad.Trans.Identity-import Control.Monad.List-import Control.Monad.Reader-import Control.Monad.Error+import Control.Monad.Trans.List+import Control.Monad.Trans.Reader+import Control.Monad.Trans.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 Control.Monad.Trans.Writer.Strict as SW+import Control.Monad.Trans.Writer.Lazy as LW+import Control.Monad.Trans.State.Strict as SS+import Control.Monad.Trans.State.Lazy as LS+import Control.Monad.Trans.RWS.Strict as SRWS+import Control.Monad.Trans.RWS.Lazy as LRWS  import Control.Exception.Lifted (SomeException, try, throwIO)  --import Network.HTTP.Types.Header (RequestHeaders)-import Network.HTTP.Client (Manager, Request, newManager, defaultManagerSettings)+import Network.HTTP.Client (Manager, Request)+import Network.HTTP.Types (RequestHeaders) +import Prelude -- hides some "unused import" warnings+ {- |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@@ -70,9 +79,29 @@                            , wdSessHTTPManager :: Manager                              -- |Number of times to retry a HTTP request if it times out                            , wdSessHTTPRetryCount :: Int-                           --, wdSessRequestHeaders :: RequestHeaders+                             -- |Custom request headers to add to every HTTP request. +                           , wdSessRequestHeaders :: RequestHeaders+                             -- |Custom request headers to add *only* to session creation requests. This is usually done+                             --  when a WebDriver server requires HTTP auth.+                           , wdSessAuthHeaders :: RequestHeaders                            } ++-- |A function used by 'wdHistoryConfig' to append new entries to session history.+type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]++-- |No session history is saved.+noHistory :: SessionHistoryConfig+noHistory _ _ = []++-- |Keep unlimited history+unlimitedHistory :: SessionHistoryConfig+unlimitedHistory = (:)++-- |Saves only the most recent history+onlyMostRecentHistory :: SessionHistoryConfig+onlyMostRecentHistory h _ = [h]+ -- |A class for monads that carry a WebDriver session with them. The -- MonadBaseControl superclass is used for exception handling through -- the lifted-base package.@@ -105,21 +134,6 @@   putSession s'   either throwIO return a --- |Constructs a new 'WDSession' from a given 'WDConfig'-mkSession :: MonadBase IO m => WDConfig -> m WDSession-mkSession WDConfig{..} = do-  manager <- maybe createManager return wdHTTPManager-  return WDSession { wdSessHost = fromString $ wdHost-                   , wdSessPort = wdPort-                   , wdSessBasePath = fromString $ wdBasePath-                   , wdSessId = Nothing-                   , wdSessHist = []-                   , wdSessHistUpdate = wdHistoryConfig-                   , wdSessHTTPManager = manager-                   , wdSessHTTPRetryCount = wdHTTPRetryCount }-  where-    createManager = liftBase $ newManager defaultManagerSettings- -- |The most recent SessionHistory entry recorded by this session, if any. mostRecentHistory :: WDSession -> Maybe SessionHistory mostRecentHistory = listToMaybe . wdSessHist@@ -128,6 +142,23 @@ mostRecentHTTPRequest :: WDSession -> Maybe Request mostRecentHTTPRequest = fmap histRequest . mostRecentHistory +-- |Set a temporary list of custom 'RequestHeaders' to use within the given action.+-- All previous custom headers are temporarily removed, and then restored at the end.+withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a+withRequestHeaders h m = do+  h' <- fmap wdSessRequestHeaders getSession+  modifySession $ \s -> s { wdSessRequestHeaders = h }+  (a :: Either SomeException a) <- try m+  modifySession $ \s -> s { wdSessRequestHeaders = h' }+  either throwIO return a++-- |Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically+-- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use+-- the same auth headers you used for session creation with other HTTP requests.+withAuthHeaders :: WDSessionStateControl m => m a -> m a+withAuthHeaders wd = do+  authHeaders <- fmap wdSessAuthHeaders getSession+  withRequestHeaders authHeaders wd                              instance WDSessionState m => WDSessionState (LS.StateT s m) where   getSession = lift getSession@@ -144,8 +175,16 @@ instance WDSessionState m => WDSessionState (IdentityT m) where   getSession = lift getSession   putSession = lift . putSession++instance WDSessionState m => WDSessionState (ListT m) where+  getSession = lift getSession+  putSession = lift . putSession    instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where+  getSession = lift getSession+  putSession = lift . putSession++instance (Monoid w, WDSessionState m) => WDSessionState (SW.WriterT w m) where   getSession = lift getSession   putSession = lift . putSession
test/search-baidu.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import           Control.Concurrent-import           Control.Parallel import           Control.Monad (void) import           Data.List import qualified Data.Text                    as T
webdriver.cabal view
@@ -1,5 +1,5 @@ Name: webdriver-Version: 0.7+Version: 0.8 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE@@ -30,18 +30,24 @@   description: Get Network.URI from the network-uri package   default: True +flag developer+  description: Package development mode+  default: False+  manual: True+ library   hs-source-dirs: src   ghc-options: -Wall+  if flag(developer)+    cpp-options: -DCABAL_BUILD_DEVELOPER   build-depends:   base == 4.*                  , aeson >= 0.6.2.0 && < 0.11                  , http-client >= 0.3 && < 0.5                  , http-types >= 0.8 && < 0.10                  , text >= 0.11.3 && < 1.3                  , bytestring >= 0.9 && < 0.11-                 , attoparsec < 0.14+                 , attoparsec >= 0.10 && < 0.14                  , base64-bytestring >= 1.0 && < 1.1-                 , mtl >= 2.0 && < 2.3                  , transformers >= 0.2 && < 0.5                  , monad-control >= 0.3 && < 1.1                  , transformers-base >= 0.1 && < 1.0@@ -56,7 +62,7 @@                  , vector >= 0.3 && < 0.12                  , exceptions >= 0.4 && < 0.9                  , scientific >= 0.2 && < 0.4-                 , data-default >= 0.2 && < 1.0+                 , data-default-class < 0.1                  , cond >= 0.3 && < 0.5                     if flag(network-uri)@@ -91,12 +97,12 @@   ghc-options: -threaded   build-depends: base,                  webdriver,-                 text,-                 parallel+                 text  --Test-Suite all-tests --  type: detailed-0.9 --  test-module: all-tests.hs+--  extensions: OverloadedStrings --  ghc-options: -Wall -threaded --  build-depends:  base, --                  webdriver,