From e295a2e93f1dc03d8c31eb78f4efb74ea6720fbb Mon Sep 17 00:00:00 2001
From: thomasjm <tom@codedown.io>
Date: Tue, 29 Oct 2024 03:39:40 -0700
Subject: [PATCH] sandwich-webdriver: moving video stuff around + trying to do
 support video flags

---
 sandwich-webdriver/sandwich-webdriver.cabal   |  4 +-
 .../src/Test/Sandwich/WebDriver.hs            | 13 ++++-
 .../src/Test/Sandwich/WebDriver/Config.hs     |  9 ++-
 .../src/Test/Sandwich/WebDriver/Video.hs      | 55 ++++++++++++++++---
 .../{Internal/Video.hs => Video/Internal.hs}  | 12 +++-
 .../Types/Video.hs => Video/Types.hs}         |  3 +-
 6 files changed, 78 insertions(+), 18 deletions(-)
 rename sandwich-webdriver/src/Test/Sandwich/WebDriver/{Internal/Video.hs => Video/Internal.hs} (92%)
 rename sandwich-webdriver/src/Test/Sandwich/WebDriver/{Internal/Types/Video.hs => Video/Types.hs} (96%)

diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal
index e4807391..1f59547f 100644
--- a/sandwich-webdriver/sandwich-webdriver.cabal
+++ b/sandwich-webdriver/sandwich-webdriver.cabal
@@ -54,10 +54,10 @@ library
       Test.Sandwich.WebDriver.Internal.Screenshots
       Test.Sandwich.WebDriver.Internal.StartWebDriver
       Test.Sandwich.WebDriver.Internal.Types
-      Test.Sandwich.WebDriver.Internal.Types.Video
       Test.Sandwich.WebDriver.Internal.Util
-      Test.Sandwich.WebDriver.Internal.Video
       Test.Sandwich.WebDriver.Types
+      Test.Sandwich.WebDriver.Video.Internal
+      Test.Sandwich.WebDriver.Video.Types
       Paths_sandwich_webdriver
   hs-source-dirs:
       src
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
index 22202d78..4dc2ddb6 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
@@ -51,6 +51,7 @@ module Test.Sandwich.WebDriver (
   , webdriverSession
   , WebDriverSession
   , HasWebDriverSessionContext
+
   -- * Shorthands
   -- | These are used to make type signatures shorter.
   , BaseMonad
@@ -90,6 +91,9 @@ 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'.
@@ -208,14 +212,19 @@ withSession session (ExampleT readerMonad) = do
   -- We could do the same here, but it's not clear that it's needed.
   let f :: m a -> m a = id
 
+  -- recordVideoInExampleT session $
   ExampleT (withReaderT (\ctx -> LabelValue (session, ref) :> ctx) $ mapReaderT (mapLoggingT f) readerMonad)
 
 -- | Convenience function. @withSession1 = withSession "session1"@.
-withSession1 :: WebDriverMonad m context => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a
+withSession1 :: (
+  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 => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a
+withSession2 :: (
+  WebDriverMonad m context
+  ) => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a
 withSession2 = withSession "session2"
 
 -- | Get all existing session names.
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs
index eb59cddb..b0e375ce 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs
@@ -16,6 +16,7 @@ module Test.Sandwich.WebDriver.Config (
   , getDisplayNumber
   , getDownloadDirectory
   , getWebDriverName
+  , getXvfbSession
 
   -- * Xvfb mode
   , XvfbConfig
@@ -35,12 +36,16 @@ module Test.Sandwich.WebDriver.Config (
   , headlessFirefoxCapabilities
 
   -- * Types
-  , WhenToSave(..)
-  , RunMode(..)
+  -- ** BrowserDependencies
   , browserDependencies
   , BrowserDependenciesSpec(..)
   , BrowserDependencies(..)
   , HasBrowserDependencies
+  -- ** Xvfb
+  , XvfbSession(..)
+  -- ** Miscellaneous
+  , WhenToSave(..)
+  , RunMode(..)
   ) where
 
 import Test.Sandwich.WebDriver.Internal.Capabilities
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
index fdec2c2d..1dcecf4a 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
@@ -11,8 +11,8 @@ module Test.Sandwich.WebDriver.Video (
   , startVideoRecording
   , endVideoRecording
 
-  -- * Helpers
-  , getXvfbSession
+  -- * Wrap an ExampleT to conditionally record video
+  -- , recordVideoInExampleT
 
   -- * Configuration
   , VideoSettings(..)
@@ -22,9 +22,6 @@ module Test.Sandwich.WebDriver.Video (
   , defaultAvfoundationOptions
   , defaultGdigrabOptions
 
-  -- * Re-exports
-  , XvfbSession(..)
-
   -- * Types
   , BaseVideoConstraints
   ) where
@@ -41,14 +38,18 @@ import System.IO
 import System.Process
 import Test.Sandwich
 import Test.Sandwich.WebDriver.Internal.Types
-import Test.Sandwich.WebDriver.Internal.Types.Video
-import Test.Sandwich.WebDriver.Internal.Video
 import Test.Sandwich.WebDriver.Types
+import Test.Sandwich.WebDriver.Video.Internal
+import Test.Sandwich.WebDriver.Video.Types
 import Test.Sandwich.WebDriver.Windows
 import Test.WebDriver.Class as W
 import Test.WebDriver.Commands
 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
@@ -132,3 +133,43 @@ endVideoRecording p = do
     ExitFailure 255 -> return ()
 
     ExitFailure n -> debug [i|ffmpeg exited with unexpected exit code #{n}'|]
+
+-- * 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)
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Internal.hs
similarity index 92%
rename from sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs
rename to sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Internal.hs
index 167727b1..880dfac9 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Internal.hs
@@ -1,7 +1,10 @@
 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
 {-# LANGUAGE CPP #-}
 
-module Test.Sandwich.WebDriver.Internal.Video where
+module Test.Sandwich.WebDriver.Video.Internal (
+  getVideoArgs
+  , videoExtension
+  ) where
 
 import Control.Monad.Catch (MonadMask)
 import Control.Monad.IO.Unlift
@@ -13,8 +16,8 @@ import Test.Sandwich
 import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg
 import Test.Sandwich.WebDriver.Internal.OnDemand
 import Test.Sandwich.WebDriver.Internal.Types
-import Test.Sandwich.WebDriver.Internal.Types.Video
 import Test.Sandwich.WebDriver.Types
+import Test.Sandwich.WebDriver.Video.Types
 
 #ifdef darwin_HOST_OS
 getMacScreenNumber :: IO (Maybe Int)
@@ -29,6 +32,9 @@ import UnliftIO.Environment
 #endif
 
 
+videoExtension :: String
+videoExtension = ".avi"
+
 getVideoArgs :: (
   MonadUnliftIO m, MonadLoggerIO m, MonadMask m
   , MonadReader context m, HasBaseContext context, HasWebDriverContext context
@@ -51,7 +57,7 @@ getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession =
           & (("XAUTHORITY", xvfbXauthority) :)
           & L.nubBy ((==) `on` fst)
 
-  let videoPath = [i|#{path}.avi|]
+  let videoPath = [i|#{path}#{videoExtension}|]
 
   let cmd = ["-y"
             , "-nostdin"
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Types.hs
similarity index 96%
rename from sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types/Video.hs
rename to sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Types.hs
index 27af549f..856962b4 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types/Video.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Types.hs
@@ -1,6 +1,5 @@
 
-module Test.Sandwich.WebDriver.Internal.Types.Video where
-
+module Test.Sandwich.WebDriver.Video.Types where
 
 
 -- | Default options for fast X11 video recording.