sandwich-webdriver: use latest process logging and managed asyncs

Author: thomasjm

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs

@@ -32,10 +32,11 @@ import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
 import UnliftIO.Directory
 
 
-type Constraints m = (
+type Constraints context m = (
   HasCallStack
   , MonadLogger m
   , MonadUnliftIO m
+  , HasBaseContextMonad context m
   )
 
 -- | Manually obtain a chrome binary, according to the 'ChromeToUse' policy,
@@ -108,7 +109,7 @@ obtainChromeDriver (UseChromeDriverFromNixpkgs nixContext) = do
   debug [i|Built chromedriver: #{ret}|]
   return $ Right ret
 
-downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)
+downloadChromeDriverIfNecessary' :: Constraints context m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)
 downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do
   let chromeDriverPath = getChromeDriverPath toolsDir chromeDriverVersion
 
@@ -118,7 +119,7 @@ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do
 
   return chromeDriverPath
 
-downloadChromeDriverIfNecessary :: Constraints m => FilePath -> FilePath -> m (Either T.Text FilePath)
+downloadChromeDriverIfNecessary :: Constraints context m => FilePath -> FilePath -> m (Either T.Text FilePath)
 downloadChromeDriverIfNecessary chromePath toolsDir = runExceptT $ do
   chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion chromePath
   ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs

@@ -1,58 +1,65 @@
 
 module Test.Sandwich.WebDriver.Internal.Binaries.Common where
 
-import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Data.String.Interpolate
 import qualified Data.Text as T
-import System.Directory
 import System.Exit
 import System.FilePath
-import System.Process
 import Test.Sandwich.Expectations
 import Test.Sandwich.Logging
+import Test.Sandwich.Misc (HasBaseContextMonad)
 import Test.Sandwich.WebDriver.Internal.Util
+import UnliftIO.Async
+import UnliftIO.Directory
+import UnliftIO.Exception
+import UnliftIO.Process
 import UnliftIO.Temporary
 
 
-downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
+  createDirectoryIfMissing True (takeDirectory localPath)
   withSystemTempDirectory "sandwich-webdriver-tool-download" $ \dir -> do
     curlDownloadToPath (T.unpack downloadPath) (dir </> "temp.zip")
 
     createProcessWithLogging ((proc "unzip" ["temp.zip", "-d", "unzipped"]) { cwd = Just dir })
-      >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+      >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                (cancel asy)
     let unzipped = dir </> "unzipped"
 
     executables <- (filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (proc "find" [unzipped, "-executable", "-type", "f"]) ""
     case executables of
-      [] -> liftIO $ throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]
+      [] -> throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]
       [x] -> do
-        liftIO $ copyFile (T.unpack x) localPath
+        copyFile (T.unpack x) localPath
         createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
-          >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
-      xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
+          >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                    (cancel asy)
+      xs -> throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
 
-downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
+  createDirectoryIfMissing True (takeDirectory localPath)
   createProcessWithLogging (shell [i|wget -qO- #{downloadPath} | tar xvz  -C #{takeDirectory localPath}|])
-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+    >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                              (cancel asy)
   createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+    >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                              (cancel asy)
 
-curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m ()
+curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> FilePath -> m ()
 curlDownloadToPath downloadPath localPath = do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
-  p <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])
-  liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+  createDirectoryIfMissing True (takeDirectory localPath)
+  (p, asy) <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])
+  finally (liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess))
+          (cancel asy)
 
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM b s = b >>= (\t -> unless t s)

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs

@@ -24,10 +24,11 @@ import Test.Sandwich.WebDriver.Internal.Util
 import UnliftIO.Directory
 
 
-type Constraints m = (
+type Constraints context m = (
   HasCallStack
   , MonadLogger m
   , MonadUnliftIO m
+  , HasBaseContextMonad context m
   )
 
 -- * Obtaining binaries
@@ -76,13 +77,13 @@ obtainSelenium (UseSeleniumFromNixpkgs nc) = do
 
 -- * Lower level helpers
 
-downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath)
+downloadSeleniumIfNecessary :: Constraints context m => FilePath -> m (Either T.Text FilePath)
 downloadSeleniumIfNecessary toolsDir = leftOnException' $ do
   let seleniumPath = [i|#{toolsDir}/selenium-server.jar|]
   liftIO (doesFileExist seleniumPath) >>= flip unless (downloadSelenium seleniumPath)
   return seleniumPath
   where
-    downloadSelenium :: Constraints m => FilePath -> m ()
+    downloadSelenium :: Constraints context m => FilePath -> m ()
     downloadSelenium seleniumPath = void $ do
       info [i|Downloading selenium-server.jar to #{seleniumPath}|]
       curlDownloadToPath defaultSeleniumJarUrl seleniumPath

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs

@@ -7,19 +7,19 @@ import Data.String.Interpolate
 import Data.Text as T
 import Test.Sandwich
 import Test.Sandwich.WebDriver.Internal.Types
-import UnliftIO.Async
+import UnliftIO.Async (wait)
 import UnliftIO.Exception
 import UnliftIO.MVar
 
 
-getOnDemand :: forall m a. (
-  MonadUnliftIO m, MonadLogger m
+getOnDemand :: forall context m a. (
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   ) => MVar (OnDemand a) -> m (Either Text a) -> m a
 getOnDemand onDemandVar doObtain = do
   result <- modifyMVar onDemandVar $ \case
     OnDemandErrored msg -> expectationFailure (T.unpack msg)
     OnDemandNotStarted -> do
-      asy <- async $ do
+      asy <- managedAsync "webdriver-on-demand" $ do
         let handler :: SomeException -> m a
             handler e = do
               modifyMVar_ onDemandVar (const $ return $ OnDemandErrored [i|Got exception: #{e}|])

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs

@@ -17,9 +17,9 @@ import GHC.Stack
 import Test.Sandwich.WebDriver.Internal.Types
 import qualified Test.WebDriver as W
 
-#ifndef mingw32_HOST_OS
-import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
-#endif
+-- #ifndef mingw32_HOST_OS
+-- import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
+-- #endif
 
 
 type Constraints m = (

sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs

@@ -48,6 +48,7 @@ import Test.Sandwich.WebDriver.Video.Internal
 import Test.Sandwich.WebDriver.Video.Types
 import Test.Sandwich.WebDriver.Windows
 import Test.WebDriver
+import UnliftIO.Async
 import UnliftIO.Directory
 import UnliftIO.Exception
 
@@ -61,6 +62,7 @@ type BaseVideoConstraints context m = (
 data VideoProcess = VideoProcess {
   -- | The process handle
   videoProcessProcess :: ProcessHandle
+  , videoProcessAsync :: Async ()
   , videoProcessCreatedFiles :: [FilePath]
   }
 -- defaultVideoProcess :: ProcessHandle -> VideoProcess
@@ -122,15 +124,16 @@ startVideoRecording path (width, height, x, y) vs = do
 
   case logToDisk vs of
     False -> do
-      p <- createProcessWithLogging cp
-      return $ VideoProcess p [videoPath]
+      (p, asy) <- createProcessWithLogging cp
+      return $ VideoProcess p asy [videoPath]
     True -> do
       let stdoutPath = path <.> "stdout" <.> "log"
       let stderrPath = path <.> "stderr" <.> "log"
       liftIO $ bracket (openFile stdoutPath AppendMode) hClose $ \hout ->
         bracket (openFile stderrPath AppendMode) hClose $ \herr -> do
           (_, _, _, p) <- createProcess (cp { std_out = UseHandle hout, std_err = UseHandle herr })
-          return $ VideoProcess p [videoPath, stdoutPath, stderrPath]
+          asy <- async $ return ()
+          return $ VideoProcess p asy [videoPath, stdoutPath, stderrPath]
 
 -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
 endVideoRecording :: (

sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs

@@ -69,7 +69,7 @@ getScreenResolution :: (MonadIO m) => TestWebDriverContext -> m (Int, Int, Int,
 -- getScreenResolution (TestWebDriverContext {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of
 --   Nothing -> liftIO getResolution
 --   Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum
-getScreenResolution twdc = liftIO getResolution
+getScreenResolution _twdc = liftIO getResolution
 
 getScreenPixelDimensions :: (WebDriver m) => Int -> Int -> m (Double, Double)
 getScreenPixelDimensions width height = do

sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs

@@ -101,7 +101,7 @@ createXvfbSession webdriverRoot w h (Fd fd) xvfbToUse xvfbOnDemand = do
 
   -- Start the Xvfb session
   authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" ""
-  p <- createProcessWithLogging $ (
+  p <- createProcessWithFileLogging $ (
     proc xvfb [":" <> show serverNum
               , "-screen", "0", [i|#{w}x#{h}x24|]
               , "-displayfd", [i|#{fd}|]