diff --git a/Test/Hspec/WebDriver.hs b/Test/Hspec/WebDriver.hs --- a/Test/Hspec/WebDriver.hs +++ b/Test/Hspec/WebDriver.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, DeriveDataTypeable, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, DeriveDataTypeable, TypeFamilies, GeneralizedNewtypeDeriving #-} -- | Write hspec tests that are webdriver tests, automatically managing the webdriver sessions. -- -- This module re-exports functions from "Test.Hspec" and "Test.WebDriver.Commands" and it is @@ -13,30 +13,33 @@ -- >main :: IO () -- >main = hspec $ -- > describe "XKCD Tests" $ do --- > it "checks hover text of 327" $ using Firefox $ do --- > openPage "http://www.xkcd.com/327/" --- > e <- findElem $ ByCSS "div#comic > img" --- > e `shouldBeTag` "img" --- > e `shouldHaveAttr` ("title", "Her daughter is named Help I'm trapped in a driver's license factory.") -- > --- > parallel $ it "checks title of 303" $ using [Firefox, Chrome] $ do --- > openPage "http://www.xkcd.com/303/" --- > e <- findElem $ ById "ctitle" --- > e `shouldBeTag` "div" --- > e `shouldHaveText` "Compiling" +-- > session "for 327" $ using Firefox $ do +-- > it "opens the page" $ runWD $ +-- > openPage "http://www.xkcd.com/327/" +-- > it "checks hover text" $ runWD $ do +-- > e <- findElem $ ByCSS "div#comic > img" +-- > e `shouldBeTag` "img" +-- > e `shouldHaveAttr` ("title", "Her daughter is named Help I'm trapped in a driver's license factory.") -- > --- > it "checks image of 1310" pending +-- > parallel $ session "for 303" $ using [Firefox, Chrome] $ do +-- > it "opens the page" $ runWD $ +-- > openPage "http://www.xkcd.com/303/" +-- > it "checks the title" $ runWD $ do +-- > e <- findElem $ ById "ctitle" +-- > e `shouldBeTag` "div" +-- > e `shouldHaveText` "Compiling" -- -- The above code assumes selenium-server-standalone is running on @127.0.0.1:4444@ at path --- @\/wd\/hub@ (this is the default). You can configure this using `createSessionManager'`. +-- @\/wd\/hub@ (this is the default). module Test.Hspec.WebDriver( -- * Webdriver BrowserDefaults(..) - , it + , session + , sessionOn + , runWD + , WDExample , Using(..) - , pending - , pendingWith - , WdExpectation(..) -- * Expectations , shouldBe @@ -46,140 +49,135 @@ , shouldReturn , shouldThrow - -- * Session Manager - , createSessionManager - , createSessionManager' - -- * Custom Capabilities , TestCapabilities(..) - -- * Re-exports from hspec + -- * Re-exports from "Test.Hspec" , hspec , Spec , describe + , it , context , parallel - -- $beforeTodo + , pending + , pendingWith -- * Re-exports from "Test.WebDriver" , WD , liftIO , module Test.WebDriver.Commands - - -- * Internal - , withCaps ) where -import Control.Exception.Lifted (try, Exception) +import Control.Exception.Lifted (try, Exception, onException, throwIO, catch) +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) +import Data.IORef import Data.Typeable (Typeable) +import Data.Word (Word16) import Test.HUnit (assertEqual, assertFailure) -import Test.Hspec hiding (shouldReturn, shouldBe, shouldSatisfy, shouldThrow, it, pending, pendingWith) -import Test.Hspec.Core (Result(..), fromSpecList, SpecTree(..), Item(..), Params) -import Test.WebDriver hiding (Browser(..)) +import qualified Data.Text as T + +import Test.Hspec hiding (shouldReturn, shouldBe, shouldSatisfy, shouldThrow) +import Test.Hspec.Core (Result(..), Item(..), mapSpecItem) +import qualified Test.Hspec as H + +import Test.WebDriver (WD) import Test.WebDriver.Commands import qualified Test.WebDriver as W -import qualified Test.Hspec as H -import qualified Data.Text as T +import qualified Test.WebDriver.Classes as W -import Test.Hspec.WebDriver.Internal +import qualified Test.Hspec.WebDriver.Internal as I --- | Webdriver expectations consist of a set of browser 'Capabilities' to use and the actual test as --- a 'W.WD' monad. The browser capabilities are specified by an enumeration which is an instance of +-- | Webdriver expectations consist of a set of browser 'W.Capabilities' to use and the actual test as +-- a 'WD' monad. The browser capabilities are specified by an enumeration which is an instance of -- 'TestCapabilities'. The @BrowserDefaults@ enumeration provides items that represent the default set of --- capabilities for each browser. When creating new sessions, the 'defaultCaps' are used. Also, --- any existing session (which exists at program startup) which matches the browser is used, no --- matter the actual capabilities. +-- capabilities for each browser (see 'W.defaultCaps'). -- -- To obtain more control over the capabilities (e.g. to test multiple versions of IE or to test -- Firefrox without javascript), you should @import Test.Hspec.WebDriver hiding (BrowserDefaults)@ -- and then create your own enumeration which is an instance of 'TestCapabilities' and 'Using'. data BrowserDefaults = Firefox | Chrome | IE | Opera | IPhone | IPad | Android - deriving (Eq, Show, Enum, Bounded, Typeable) - -instance TestCapabilities BrowserDefaults where - matchesCaps Firefox (Capabilities { browser = W.Firefox _ _ _ }) = True - matchesCaps Chrome (Capabilities { browser = W.Chrome _ _ _ _ }) = True - matchesCaps IE (Capabilities { browser = W.IE _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ }) = True - matchesCaps Opera (Capabilities { browser = W.Opera _ _ _ _ _ _ _ _ _ _ _ _ }) = True - matchesCaps IPhone (Capabilities { browser = W.IPhone}) = True - matchesCaps IPad (Capabilities { browser = W.IPad }) = True - matchesCaps Android (Capabilities { browser = W.Android }) = True - matchesCaps _ _ = False + deriving (Eq, Show, Enum, Bounded) - newCaps Firefox = return $ defaultCaps { browser = firefox } - newCaps Chrome = return $ defaultCaps { browser = chrome } - newCaps IE = return $ defaultCaps { browser = ie } - newCaps Opera = return $ defaultCaps { browser = opera } - newCaps IPhone = return $ defaultCaps { browser = iPhone } - newCaps IPad = return $ defaultCaps { browser = iPad } - newCaps Android = return $ defaultCaps { browser = android } +-- | Provides information about the browser capabilities used for testing. If you want more control +-- over capabilities, you should hide 'BrowserDefaults' and then make an enumeration of all the +-- webdriver capabilities you will be testing with. For example, +-- +-- >data TestCaps = Firefox +-- > | FirefoxWithoutJavascript +-- > | Chrome +-- > | IE8 +-- > | IE9 +-- > deriving (Show, Eq, Bounded, Enum) +-- +-- @TestCaps@ must then be made an instance of @TestCapabilities@. Also, instances of @Using@ +-- should be created. +class Show c => TestCapabilities c where + -- | The capabilities to pass to 'createSession'. + newCaps :: c -> WD W.Capabilities --- | A webdriver expectation is either an action and a list of capabilities (which should be an instance of --- 'TestCapabilities') or a pending message. -data WdExpectation cap = WdTest [cap] (WD ()) - | WdPending (Maybe String) +instance TestCapabilities BrowserDefaults where + newCaps Firefox = return $ W.defaultCaps { W.browser = W.firefox } + newCaps Chrome = return $ W.defaultCaps { W.browser = W.chrome } + newCaps IE = return $ W.defaultCaps { W.browser = W.ie } + newCaps Opera = return $ W.defaultCaps { W.browser = W.opera } + newCaps IPhone = return $ W.defaultCaps { W.browser = W.iPhone } + newCaps IPad = return $ W.defaultCaps { W.browser = W.iPad } + newCaps Android = return $ W.defaultCaps { W.browser = W.android } --- | Evaluate an expectation to a list of the function expected by hspec. -evaluateWd :: (Show cap, TestCapabilities cap) => WdExpectation cap -> [(String,Params -> (IO () -> IO ()) -> IO Result)] -evaluateWd (WdPending msg) = [("", \_ _ -> return $ Pending msg)] -evaluateWd (WdTest cs test) = map mkItem cs - where - mkItem c = ("using " ++ show c, eval c) +-- | Combine the examples nested inside this call into a webdriver session. For each capability in +-- the list, before the first example is executed, a new webdriver session is created using the +-- capabilities. The examples are then executed in depth-first order using this webdriver session +-- (so later examples can rely on the browser state created by earlier examples). Once the final +-- example has executed, the session is closed. If some 'WDExample' fails (throws an exception), +-- all remaining examples in the session will become pending. +-- +-- Note that when using 'parallel', the examples within a single session will still execute +-- serially. Different sessions (including the multiple sessions created if more than one +-- capability is passed to 'session') will be executed in parallel. +-- +-- This function uses the default webdriver host (127.0.0.1), port (4444), and +-- basepath (@\/wd\/hub@). +session :: TestCapabilities cap => String -> ([cap], Spec) -> Spec +session = hSessionWd W.defaultSession - eval :: TestCapabilities c => c -> params -> (IO () -> IO ()) -> IO Result - eval c _ action = do action (runWD defaultSession $ withCaps c test) - return Success +-- | A variation of 'session' which allows you to specify the webdriver host, port, and basepath. +sessionOn :: TestCapabilities cap + => String -- ^ host + -> Word16 -- ^ port + -> String -- ^ base path + -> String -- ^ message + -> ([cap], Spec) + -> Spec +sessionOn host port bp = hSessionWd W.WDSession { W.wdHost = host + , W.wdPort = port + , W.wdBasePath = bp + , W.wdSessId = Nothing + , W.lastHTTPRequest = Nothing + } --- | A typeclass of things which can be converted to a 'WdExpectation'. This is the primary method --- to create expectations to pass to 'it'. Both a single 'BrowserDefaults' and a list --- of 'BrowserDefaults' can be used. +-- | A typeclass of things which can be converted to a list of capabilities. It's primary purpose +-- is to allow the word @using@ to be used with 'session' so that the session description reads like +-- a sentance. -- --- >it "opens the home page" $ using Firefox $ do --- > ... --- >it "opens the users page" $ using [Firefox, Chrome] $ do +-- >session "for the home page" $ using Firefox $ do +-- > it "loads the page" $ runWD $ do +-- > ... +-- > it "scrolls the carosel" $ runWD $ do +-- > ... +-- >session "for the users page" $ using [Firefox, Chrome] $ do -- > ... class Using a where - type UsingCapabilities a :: * - using :: a -> WD () -> WdExpectation (UsingCapabilities a) + type UsingList a + using :: a -> Spec -> (UsingList a, Spec) instance Using BrowserDefaults where - type UsingCapabilities BrowserDefaults = BrowserDefaults - using d = WdTest [d] + type UsingList BrowserDefaults = [BrowserDefaults] + using d s = ([d], s) instance Using [BrowserDefaults] where - type UsingCapabilities [BrowserDefaults] = BrowserDefaults - using = WdTest - --- | Create a spec from a webdriver expectation. --- --- The webdriver expectation consists of a list of browser capabilities and the actual test. The --- test will be executed once for each set of capabilities in the list. By default, the tests will be --- executed serially. You can use 'parallel' to execute the test on all capabilities in parallel. --- --- To run the test, a webdriver session is allocated from a pool of sessions (in a thread-safe --- manner). The pools will be initialized automatically from existing sessions the first time a --- test is run; you can explicitly create the pools using 'createSessionManager'. -it :: (Show cap, TestCapabilities cap) => String -> WdExpectation cap -> Spec -it msg a = spec - where - mkItem m f = SpecItem Item { itemIsParallelizable = False - , itemRequirement = m - , itemExample = f - } - spec = case evaluateWd a of - [] -> fromSpecList [] - [("",f)] -> fromSpecList [mkItem (msg) f] - [(m,f)] -> fromSpecList [mkItem (msg ++ " " ++ m) f] - ss -> describe msg $ fromSpecList $ map (uncurry mkItem) ss - --- | A 'WdExpectation' that is pending. -pending :: WdExpectation () -pending = WdPending Nothing - --- | A 'WdExpectation' that is pending, with a message. -pendingWith :: String -> WdExpectation () -pendingWith = WdPending . Just + type UsingList [BrowserDefaults] = [BrowserDefaults] + using d s = (d, s) -- | 'H.shouldBe' lifted into the 'WD' monad. shouldBe :: (Show a, Eq a) => a -> a -> WD () @@ -215,5 +213,61 @@ Left err -> err `shouldBe` expected Right _ -> liftIO $ assertFailure $ "did not get expected exception " ++ show expected --- $beforeTodo --- Future TODO: lift 'before', 'after', and 'around' into the 'WD' monad. + +-------------------------------------------------------------------------------- +-- Internal Test Runner +-------------------------------------------------------------------------------- + +-- | State passed between examples +data WdState = WdState { + stSession :: W.WDSession -- ^ the webdriver session + , stError :: IORef Bool -- ^ has an error occured in an earlier example? We rely on the serialization + -- of examples to ensure that at most one thread is reading/writing this + -- ioref. +} deriving Typeable + +-- | Used to signal that a previous example had an error +data PrevHasError = PrevHasError + deriving (Show, Typeable) +instance Exception PrevHasError + +-- | The initial session is used only for its host, port, and basepath. A new session is created. +createSt :: TestCapabilities cap => W.WDSession -> cap -> IO WdState +createSt sess cap = do + err <- newIORef False + sess' <- W.runWD sess $ newCaps cap >>= createSession + return $ WdState sess' err + +closeSt :: WdState -> IO () +closeSt st = W.runWD (stSession st) closeSession + +-- | The 'WDSession' passed in is used for its host, port, and base path. +hSessionWd :: TestCapabilities cap => W.WDSession -> String -> ([cap], Spec) -> Spec +hSessionWd sess msg (caps, spec) = spec' + where + spec' = case caps of + [] -> it msg $ pendingWith "No capabilities specified" + [c] -> describe (msg ++ " using " ++ show c) $ proc c spec + _ -> describe msg $ mapM_ (\c -> describe ("using " ++ show c) $ proc c spec) caps + + proc cap = mapSpecItem addCatchResult . I.session (createSt sess cap) closeSt + + addCatchResult item = item { + itemExample = \p a -> itemExample item p a + `catch` \PrevHasError -> return $ Pending $ Just "previous example had error" } + +-- | An example that can be passed to 'it' containing a webdriver action. It must be created with +-- 'runWD'. +newtype WDExample = WdExample (I.SessionExample WdState) + deriving Example + +-- | Create an example from a 'WD' action. This /must/ be nested inside a call to 'session' or +-- 'sessionOn'. +runWD :: WD () -> WDExample +runWD w = WdExample $ I.SessionExample $ \s -> W.runWD (stSession s) $ do + err <- liftIO $ readIORef $ stError s + when err $ throwIO PrevHasError + + w `onException` liftIO (writeIORef (stError s) True) + swd <- W.getSession + return s { stSession = swd } diff --git a/Test/Hspec/WebDriver/Internal.hs b/Test/Hspec/WebDriver/Internal.hs --- a/Test/Hspec/WebDriver/Internal.hs +++ b/Test/Hspec/WebDriver/Internal.hs @@ -1,213 +1,160 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Test.Hspec.WebDriver.Internal( - TestCapabilities(..) - , createSessionManager - , createSessionManager' - , withCaps +{-# LANGUAGE DeriveDataTypeable, RankNTypes, FlexibleContexts, ScopedTypeVariables #-} +module Test.Hspec.WebDriver.Internal ( + -- * State Sessions + session + , runState + , with + , SessionExample(..) ) where -import Control.Concurrent.STM -import Control.Exception.Lifted (finally, onException) -import Control.Monad.IO.Class (liftIO) -import Data.Hashable -import Data.List (partition) -import Data.Maybe (fromJust) -import Data.Typeable -import Data.Word (Word16) +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad.Trans.State (state, evalState, execState, execStateT, StateT) +import Data.Traversable (traverse) +import Data.Typeable (Typeable(..), cast) import System.IO.Unsafe (unsafePerformIO) -import Test.WebDriver -import Test.WebDriver.Classes -import qualified Data.HashMap.Lazy as M +import Test.Hspec +import Test.Hspec.Core hiding (describe, it, hspec) --- | Provides information about the browser capabilities used for testing. If you want more control --- over capabilities, you should hide @BrowserDefaults@ and then make --- an enumeration of all the webdriver capabilities you will be testing with. For example, --- --- >data TestCaps = Firefox --- > | FirefoxWithoutJavascript --- > | Chrome --- > | IE8 --- > | IE9 --- > deriving (Show, Eq, Bounded, Enum, Typeable) --- --- @TestCaps@ must then be made an instance of @TestCapabilities@. Also, instances of @Using@ --- should be created. -class (Eq c, Enum c, Typeable c) => TestCapabilities c where +import qualified Control.Exception as E - -- | Check if the 'Capabilities' match your enumeration. Note that these capabilities - -- will be the actual capabilities (with things like version information filled in) - -- so you should not use @==@ to compare capabilities, only check the actual capabilities you - -- care about. - matchesCaps :: c -> Capabilities -> Bool +traverseTree :: Applicative f => (Item -> f Item) -> SpecTree -> f SpecTree +traverseTree f (SpecItem i) = SpecItem <$> f i +traverseTree f (SpecGroup msg ss) = SpecGroup msg <$> traverse (traverseTree f) ss - -- | The capabilities to pass to 'createSession' when no existing session is found. - newCaps :: c -> WD Capabilities +traverseSpec :: Applicative f => (Item -> f Item) -> Spec -> f Spec +traverseSpec f s = fromSpecList <$> traverse (traverseTree f) (runSpecM s) --- | This instance is used for pending messages, no capabilities are matched or created. -instance TestCapabilities () where - matchesCaps () _ = False - newCaps () = error "Cannot create caps for ()" +-- | Process the items in a depth-first walk, passing in the item counter value. +mapWithCounter :: (Int -> Item -> Item) -> Spec -> Spec +mapWithCounter f s = flip evalState 0 $ traverseSpec go s + where + go item = state $ \cnt -> (f cnt item, cnt+1) -data SomeCap = forall c. TestCapabilities c => SomeCap c +countItems :: Spec -> Int +countItems s = flip execState 0 $ traverseSpec go s + where + go item = state $ \cnt -> (item, cnt+1) -instance Eq SomeCap where - SomeCap c1 == SomeCap c2 = case cast c2 of - Just c2' -> c1 == c2' - Nothing -> False -instance Hashable SomeCap where - hashWithSalt i (SomeCap c) = hashUsing fromEnum i c +data SessionTest a = SessionTest (IO () -> IO ()) (a -> IO a) + deriving Typeable +instance Show (SessionTest a) where + show _ = "Test must be contained within a session of matching state type" +instance Typeable a => E.Exception (SessionTest a) -data ManagedSessions = ManagedSessions - { maxSessions :: Int - -- ^ maximum number of sessions that should be created - , managedSessions :: M.HashMap SomeCap (TVar ([SessionId],Int)) - -- ^ For each cap, store the list of unused sessions and a count of in-use sessions. - , initialSessions :: [(SessionId,Capabilities)] - -- ^ sessions which existed at program start and are not yet assigned. +-- | A session example, which contains an expectation and also transforms the state. +-- @SessionExample@s must be located as a child to a call to 'session' and the type @s@ must match between +-- the example and the call to 'session'. Sessions cannot be nested, so if there is no parent call +-- to 'session' or the types @s@ do not match, the example will fail. +data SessionExample s = SessionExample (s -> IO s) +instance Typeable a => Example (SessionExample a) where + evaluateExample (SessionExample f) _ act = E.throwIO $ SessionTest act f - -- | settings for session - , mwdHost :: String - , mwdPort :: Word16 - , mwdBasePath :: String - } +data Session a = Session { + sessionCount :: Int + , sessionMVars :: [MVar (Either E.SomeException a)] + , sessionCreate :: IO a + , sessionClose :: a -> IO () +} --- | Stores the managed sessions -sessionManager :: TVar (Maybe ManagedSessions) -{-# NOINLINE sessionManager #-} -sessionManager = unsafePerformIO (newTVarIO Nothing) +sessionItem :: Typeable a => Session a -> Int -> Item -> Item +sessionItem sess i item = item { itemExample = \p a -> runTest $ itemExample item p a } + where + open | i == 0 = E.try $ sessionCreate sess + | otherwise = takeMVar $ sessionMVars sess !! i --- | Create and set the session manager -createWdMan :: Int -> Maybe (String, Word16, String) -> WD () -createWdMan maxSess mSettings = do - let (host,port,bpath) = case mSettings of - Just s -> s - Nothing -> (wdHost defaultSession, wdPort defaultSession, wdBasePath defaultSession) - sess <- sessions + close ma | i == sessionCount sess - 1 = either (const $ return ()) (sessionClose sess) ma + | otherwise = putMVar (sessionMVars sess !! (i+1)) ma - let manager = ManagedSessions maxSess M.empty sess host port bpath + runTest ex = do + ma <- open + mres <- E.try ex + case mres of + -- normal, non-session test. Use the original state ma for the next test. + Right res -> close ma >> return res - liftIO $ atomically $ do - mm <- readTVar sessionManager - case mm of - Just _ -> return () -- manager has already been created - Nothing -> writeTVar sessionManager $ Just manager + Left (E.SomeException err) -> do + case (ma, cast err) of + -- non-session test threw an error (since the cast to SessionTest + -- failed). Use the original state ma for the next test and rethrow the + -- error. + (_, Nothing) -> close ma >> E.throwIO err --- | Create a new session manager using the default webdriver host (127.0.0.1), port (4444), and --- basepath (@\/wd\/hub@). + -- A session test, where in addition the open function succeeded. + (Right a, Just (SessionTest act f)) -> do + act $ do + a' <- f a + `E.onException` close ma -- use old state on error + close $ Right a' -- use new state + return Success + + -- A session test where the state ma is an error (which is the error + -- thrown by open). Pass the error ma to the next test and throw the + -- error. + (Left err', _) -> close ma >> E.throwIO err' + +-- | This function causes all child examples (sessions cannot be nested) to be executed serially in +-- depth-first order, tracking a state of type @s@ throughout the examples as they are processed in +-- order. Examples which are 'SessionExample's (which are essentially functions @s -> IO s@) can view +-- and modify the state. -- --- The session manager hands out sessions to tests (in a thread-safe manner). Threads ask for --- sessions by an enumeration which is an instance of 'TestCapabilities', and the manager stores a --- pool of sessions for each enumeration item. When calling 'createSessionManager', the already --- existing sessions are loaded and used as the initial sessions in the pools. If a thread asks for --- a session but none is available, one of two things happens: if the total number of sessions for --- this enumeration item is larger than the argument to 'createSessionManager', the thread will --- block until a session is available. If the total number of sessions for this enumeration item is --- smaller, a new session will be created. This is only relevant if you run tests in parallel, --- since when running tests serially at most one session will be in use at any one time in any case. --- Note that sessions are never closed by the manager. +-- * If an example is not a 'SessionExample', the example is executed and there is no change in the +-- state. -- --- If you do not call 'createSessionManager', when the very first test is run a new manager will be --- created where the maximum number of sessions per enumeration item is one. -createSessionManager :: Int -- ^ threshold number of sessions per enumeration item beyond which new - -- sessions are no longer created. Note you can set this to zero so - -- that new sessions are never created; the only sessions used will be - -- those that already exist. - -> IO () -createSessionManager maxSess = runWD defaultSession $ createWdMan maxSess Nothing - --- | Same as 'createSessionManager' but allows you to specify the webdriver host, port, and base --- path for all sessions. -createSessionManager' :: Int -- ^ threshold number of sessions per enumeration item - -> String -- ^ host - -> Word16 -- ^ port - -> String -- ^ base path - -> IO () -createSessionManager' maxSess host port bpath = do - let sess = WDSession { wdHost = host - , wdPort = port - , wdBasePath = bpath - , wdSessId = Nothing - , lastHTTPRequest = Nothing - } - runWD sess $ createWdMan maxSess $ Just (host, port, bpath) - --- | Create a session -createSessionId :: SomeCap -> WD SessionId -createSessionId (SomeCap c) = do - caps <- newCaps c - sess <- createSession caps - return $ fromJust $ wdSessId sess - --- | Searches for a session. Returns the action to be used to obtain the session. -findSession :: SomeCap -> ManagedSessions -> STM (WD SessionId) -findSession sc@(SomeCap c) m = - case M.lookup sc $ managedSessions m of - Just tvar -> do - (sess,count) <- readTVar tvar - case sess of - (s:ss) -> do writeTVar tvar (ss, count + 1) - return $ return s - - [] | count >= maxSessions m -> retry -- retry blocks until a tvar changes - - | otherwise -> do writeTVar tvar ([], count + 1) - let create = createSessionId sc `onException` (liftIO $ atomically $ do - (s',cnt) <- readTVar tvar - writeTVar tvar (s', cnt - 1)) - return create - - Nothing -> do - let (sess, unmanaged') = partition (\(_,cap) -> matchesCaps c cap) $ initialSessions m - tvar <- newTVar (map fst sess, 0) - let m' = m { initialSessions = unmanaged' - , managedSessions = M.insert sc tvar $ managedSessions m - } - writeTVar sessionManager $ Just m' - findSession sc m' - --- | Take a session out of the pool, using an existing unused session, creating a new session, or --- blocking if the maximum number of sessions already exist. The new session is set into the 'WD' --- monad. Note the session can leak if you do not properly call 'putSessionId'. -takeSession :: TestCapabilities s => s -> WD () -takeSession s = do - msess <- liftIO $ atomically $ do - mm <- readTVar sessionManager - case mm of - Nothing -> return Nothing - Just m -> do r <- findSession (SomeCap s) m - return $ Just (r, mwdHost m, mwdPort m, mwdBasePath m) - case msess of - Just (r, host, port, bpath) -> do - let sess = WDSession { wdHost = host - , wdPort = port - , wdBasePath = bpath - , wdSessId = Nothing - , lastHTTPRequest = Nothing - } - putSession sess - sid <- r - putSession sess { wdSessId = Just sid } - - Nothing -> do - createWdMan 1 Nothing - takeSession s +-- * If an example is a 'SessionExample' but throws an exception, there is no change in the state. +-- +-- * If an example is a 'SessionExample' and completes successfully, the state returned from the +-- example is used as the new state. +-- +-- Just before the first example is run, the create action is executed to obtain the initial state. +-- If the create action throws an error, all of the child 'SessionExample' will report this error. +-- Once the final example is run, the cleanup action is executed with the current state (which is +-- the intial state passed through all successful examples). An exception in the cleanup function +-- is ignored. +-- +-- If you use 'parallel', the child examples in the session will still be executed serially in +-- depth-first order so that the state is processed through properly. But multiple sessions will be +-- executed in parallel. +session :: Typeable s => IO s -- ^ create the state + -> (s -> IO ()) -- ^ cleanup the state + -> Spec -- ^ spec tree to process + -> Spec +session create close s = unsafePerformIO $ do + let cnt = countItems s + mvars <- sequence $ take cnt $ repeat newEmptyMVar + let sess = Session cnt mvars create close + return $ mapWithCounter (sessionItem sess) s --- | Add a session ID back into the pool. -putSessionId :: TestCapabilities s => s -> SessionId -> WD () -putSessionId s sid = liftIO $ atomically $ do - mm <- readTVar sessionManager - let m = maybe (error "Cannot put a session to an uninitialized manager") id mm - case M.lookup (SomeCap s) $ managedSessions m of - Nothing -> error "Cannot put a session to a cap that does not exist" - Just tvar -> do - (ss,cnt) <- readTVar tvar - writeTVar tvar (sid:ss,cnt-1) +-- | Create an example to pass to 'it' which accesses and modifies the state using the state monad. +-- For example, +-- +-- >it "checks the state" $ runState $ do +-- > s <- get +-- > liftIO $ s `shouldBe` "Hello, World" +runState :: StateT s IO () -> SessionExample s +runState = SessionExample . execStateT --- | Find or create a new session, set it into the 'WD' monad, run the given action, and return the --- session back into the pool once the action completes or an exception occurs. -withCaps :: TestCapabilities s => s -> WD a -> WD a -withCaps tc test = do - takeSession tc - sess <- getSession - test `finally` putSessionId tc (fromJust $ wdSessId sess) +-- | Create an example to pass to 'it' which only reads the state. This is useful for bracketing +-- tests with some resource. For example, +-- +-- >openDb :: IO DbConnection +-- >openDb = ... +-- > +-- >closeDb :: DbConnection -> IO () +-- >closeDb = ... +-- > +-- >dbSessionWhich :: String -> Spec -> Spec +-- >dbSessionWhich msg = session openDb closeDb . describe msg +-- > +-- >spec :: Spec +-- >spec = +-- > ... +-- > dbSessionWhich "checks users" $ do +-- > it "adds a user" $ with $ \db -> do +-- > ... something with db ... +-- > +-- > it "loads the user" $ with $ \db -> do +-- > ... something with db ... +with :: (s -> IO ()) -> SessionExample s +with f = SessionExample $ \a -> f a >> return a diff --git a/hspec-webdriver.cabal b/hspec-webdriver.cabal --- a/hspec-webdriver.cabal +++ b/hspec-webdriver.cabal @@ -1,5 +1,5 @@ name: hspec-webdriver -version: 0.1.0 +version: 0.2.0 cabal-version: >= 1.8 build-type: Simple synopsis: Write end2end web application tests using webdriver and hspec