Skip to content

Commit

Permalink
sandwich-webdriver: video recording seems to work
Browse files Browse the repository at this point in the history
  • Loading branch information
thomasjm committed Oct 31, 2024
1 parent e295a2e commit 174e718
Show file tree
Hide file tree
Showing 3 changed files with 51 additions and 56 deletions.
1 change: 1 addition & 0 deletions demos/demo-discover/app/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,4 +10,5 @@ import Test.Sandwich.WebDriver
type SeleniumSpec = forall context. (
HasBaseContext context
, HasWebDriverContext context
, HasSomeCommandLineOptions context
) => SpecFree context IO ()
27 changes: 13 additions & 14 deletions sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

Expand Down Expand Up @@ -67,9 +65,10 @@ module Test.Sandwich.WebDriver (
, module Test.Sandwich.WebDriver.Config
) where

import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.IORef
import qualified Data.List as L
import qualified Data.Map as M
Expand All @@ -78,22 +77,19 @@ import Data.String.Interpolate
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.Internal
import Test.Sandwich.WebDriver.Binaries
import Test.Sandwich.WebDriver.Config
import Test.Sandwich.WebDriver.Internal.Action
import Test.Sandwich.WebDriver.Internal.Dependencies
import Test.Sandwich.WebDriver.Internal.StartWebDriver
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Types
import Test.Sandwich.WebDriver.Video (recordVideoIfConfigured)
import qualified Test.WebDriver as W
import qualified Test.WebDriver.Config as W
import qualified Test.WebDriver.Session as W
import UnliftIO.MVar

-- import Control.Monad.Catch (MonadMask)
-- import Test.Sandwich.WebDriver.Video (recordVideoInExampleT)


-- | Introduce a 'WebDriver', using the given 'WebDriverDependencies'.
-- A good default is 'defaultWebDriverDependencies'.
Expand Down Expand Up @@ -188,13 +184,14 @@ cleanupWebDriver sess = do

-- | Run a given example using a given Selenium session.
withSession :: forall m context a. (
WebDriverMonad m context
MonadMask m, MonadBaseControl IO m
, HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context
)
-- | Session to run
=> Session
-> ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a
-> ExampleT context m a
withSession session (ExampleT readerMonad) = do
withSession session action = do
WebDriver {..} <- getContext webdriver
-- Create new session if necessary (this can throw an exception)
sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup session sessionMap of
Expand All @@ -210,20 +207,22 @@ withSession session (ExampleT readerMonad) = do

-- Not used for now, but previous libraries have use a finally to grab the final session on exception.
-- We could do the same here, but it's not clear that it's needed.
let f :: m a -> m a = id
-- let f :: m a -> m a = id

-- recordVideoInExampleT session $
ExampleT (withReaderT (\ctx -> LabelValue (session, ref) :> ctx) $ mapReaderT (mapLoggingT f) readerMonad)
pushContext webdriverSession (session, ref) $
recordVideoIfConfigured session action

-- | Convenience function. @withSession1 = withSession "session1"@.
withSession1 :: (
WebDriverMonad m context
MonadMask m, MonadBaseControl IO m
, HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context
) => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a
withSession1 = withSession "session1"

-- | Convenience function. @withSession2 = withSession "session2"@.
withSession2 :: (
WebDriverMonad m context
MonadMask m, MonadBaseControl IO m
, HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context
) => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a
withSession2 = withSession "session2"

Expand Down
79 changes: 37 additions & 42 deletions sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ module Test.Sandwich.WebDriver.Video (
, endVideoRecording

-- * Wrap an ExampleT to conditionally record video
-- , recordVideoInExampleT
, recordVideoIfConfigured

-- * Configuration
, VideoSettings(..)
Expand All @@ -31,6 +31,7 @@ import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger hiding (logError)
import Control.Monad.Reader
import Data.Function
import Data.String.Interpolate
import System.Exit
import System.FilePath
Expand All @@ -44,12 +45,9 @@ import Test.Sandwich.WebDriver.Video.Types
import Test.Sandwich.WebDriver.Windows
import Test.WebDriver.Class as W
import Test.WebDriver.Commands
import UnliftIO.Directory
import UnliftIO.Exception

-- import Control.Monad.Trans.Control (MonadBaseControl)
-- import Data.Function
-- import UnliftIO.Directory


type BaseVideoConstraints context m = (
MonadLoggerIO m, MonadUnliftIO m, MonadMask m
Expand Down Expand Up @@ -136,40 +134,37 @@ endVideoRecording p = do

-- * Wrappers

-- recordVideoInExampleT :: (
-- MonadUnliftIO m, MonadMask m, MonadBaseControl IO m
-- , HasBaseContext ctx, HasWebDriverContext ctx, HasWebDriverSessionContext ctx, HasSomeCommandLineOptions ctx
-- ) => String -> ExampleT ctx m a -> ExampleT ctx m a
-- recordVideoInExampleT browser action = do
-- getCurrentFolder >>= \case
-- Nothing -> action
-- Just folder -> do
-- SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions
-- if | optIndividualVideos -> withVideo folder browser action
-- | optErrorVideos -> withVideoIfException folder browser action
-- | otherwise -> action

-- withVideo :: (
-- MonadUnliftIO m, MonadMask m, MonadBaseControl IO m
-- , HasBaseContext ctx, HasWebDriverContext ctx, HasWebDriverSessionContext ctx
-- ) => FilePath -> String -> ExampleT ctx m a -> ExampleT ctx m a
-- withVideo folder browser action = do
-- path <- getPathInFolder folder browser
-- bracket (startBrowserVideoRecording path defaultVideoSettings) endVideoRecording (const action)

-- withVideoIfException :: (
-- MonadUnliftIO m, MonadMask m, MonadBaseControl IO m
-- , HasBaseContext ctx, HasWebDriverContext ctx, HasWebDriverSessionContext ctx
-- ) => FilePath -> String -> ExampleT ctx m a -> ExampleT ctx m a
-- withVideoIfException folder browser action = do
-- path <- getPathInFolder folder browser
-- tryAny (bracket (startBrowserVideoRecording path defaultVideoSettings) (endVideoRecording) (const action)) >>= \case
-- Right ret -> removePathForcibly path >> return ret
-- Left e -> throwIO e

-- getPathInFolder :: (MonadUnliftIO m) => [Char] -> String -> m FilePath
-- getPathInFolder folder browser = flip fix (0 :: Integer) $ \loop n -> do
-- let path = folder </> [i|#{browser}_video_#{n}|]
-- liftIO (doesFileExist (path <> videoExtension)) >>= \case
-- False -> return path
-- True -> loop (n + 1)
recordVideoIfConfigured :: (
BaseVideoConstraints context m, W.WebDriver m, HasSomeCommandLineOptions context
) => String -> m a -> m a
recordVideoIfConfigured browser action = do
getCurrentFolder >>= \case
Nothing -> action
Just folder -> do
SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions
if | optIndividualVideos -> withVideo folder browser action
| optErrorVideos -> withVideoIfException folder browser action
| otherwise -> action

withVideo :: (
BaseVideoConstraints context m, W.WebDriver m
) => FilePath -> String -> m a -> m a
withVideo folder browser action = do
path <- getPathInFolder folder browser
bracket (startBrowserVideoRecording path defaultVideoSettings) endVideoRecording (const action)

withVideoIfException :: (
BaseVideoConstraints context m, W.WebDriver m
) => FilePath -> String -> m a -> m a
withVideoIfException folder browser action = do
path <- getPathInFolder folder browser
tryAny (bracket (startBrowserVideoRecording path defaultVideoSettings) (endVideoRecording) (const action)) >>= \case
Right ret -> removePathForcibly path >> return ret
Left e -> throwIO e

getPathInFolder :: (MonadUnliftIO m) => [Char] -> String -> m FilePath
getPathInFolder folder browser = flip fix (0 :: Integer) $ \loop n -> do
let path = folder </> [i|#{browser}_video_#{n}|]
liftIO (doesFileExist (path <> videoExtension)) >>= \case
False -> return path
True -> loop (n + 1)

0 comments on commit 174e718

Please sign in to comment.