From 174e7188b24f90fc41ae99a4386e56bba47a70c4 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Thu, 31 Oct 2024 01:49:17 -0700 Subject: [PATCH] sandwich-webdriver: video recording seems to work --- demos/demo-discover/app/Types.hs | 1 + .../src/Test/Sandwich/WebDriver.hs | 27 +++---- .../src/Test/Sandwich/WebDriver/Video.hs | 79 +++++++++---------- 3 files changed, 51 insertions(+), 56 deletions(-) diff --git a/demos/demo-discover/app/Types.hs b/demos/demo-discover/app/Types.hs index fa38b608..03a7fd6e 100644 --- a/demos/demo-discover/app/Types.hs +++ b/demos/demo-discover/app/Types.hs @@ -10,4 +10,5 @@ import Test.Sandwich.WebDriver type SeleniumSpec = forall context. ( HasBaseContext context , HasWebDriverContext context + , HasSomeCommandLineOptions context ) => SpecFree context IO () diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index 4dc2ddb6..aa5902d9 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -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 @@ -78,7 +77,6 @@ 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 @@ -86,14 +84,12 @@ 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'. @@ -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 @@ -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" diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs index 1dcecf4a..2eb4c3e9 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs @@ -12,7 +12,7 @@ module Test.Sandwich.WebDriver.Video ( , endVideoRecording -- * Wrap an ExampleT to conditionally record video - -- , recordVideoInExampleT + , recordVideoIfConfigured -- * Configuration , VideoSettings(..) @@ -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 @@ -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 @@ -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)