From ed1fb923931af75390312655021f04ee6d5345a1 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Thu, 29 Feb 2024 03:14:43 -0800 Subject: [PATCH] Done embracing unliftio --- sandwich-hedgehog/package.yaml | 2 ++ sandwich-hedgehog/sandwich-hedgehog.cabal | 4 +++ .../src/Test/Sandwich/Hedgehog.hs | 27 ++++++++++--------- .../src/Test/Sandwich/Hedgehog/Render.hs | 6 ++--- sandwich-quickcheck/package.yaml | 1 + sandwich-quickcheck/sandwich-quickcheck.cabal | 4 ++- .../src/Test/Sandwich/QuickCheck.hs | 26 +++++++++--------- sandwich-slack/package.yaml | 1 + sandwich-slack/sandwich-slack.cabal | 5 +++- .../src/Test/Sandwich/Formatters/Slack.hs | 16 +++++++---- .../Formatters/Slack/Internal/Markdown.hs | 3 ++- .../Formatters/Slack/Internal/ProgressBar.hs | 2 +- .../Test/Sandwich/WebDriver/Resolution.hs | 6 +++-- sandwich-webdriver/package.yaml | 1 + sandwich-webdriver/sandwich-webdriver.cabal | 3 +++ .../src/Test/Sandwich/WebDriver.hs | 8 +++--- .../Sandwich/WebDriver/Internal/Action.hs | 2 -- .../Sandwich/WebDriver/Internal/Binaries.hs | 2 -- .../Internal/Binaries/DetectChrome.hs | 11 ++++---- .../Internal/Binaries/DetectFirefox.hs | 1 + .../WebDriver/Internal/Screenshots.hs | 3 +-- .../WebDriver/Internal/StartWebDriver.hs | 23 ++++++++++------ .../Test/Sandwich/WebDriver/Internal/Types.hs | 14 ++++++++-- .../Test/Sandwich/WebDriver/Internal/Util.hs | 2 -- .../Test/Sandwich/WebDriver/Internal/Video.hs | 1 + .../src/Test/Sandwich/WebDriver/Types.hs | 10 ++++--- .../src/Test/Sandwich/WebDriver/Video.hs | 9 ++++--- .../src/Test/Sandwich/WebDriver/Windows.hs | 13 ++++----- .../WebDriver/Internal/StartWebDriver/Xvfb.hs | 5 ++-- 29 files changed, 125 insertions(+), 86 deletions(-) diff --git a/sandwich-hedgehog/package.yaml b/sandwich-hedgehog/package.yaml index 1def644..cdd1c7b 100644 --- a/sandwich-hedgehog/package.yaml +++ b/sandwich-hedgehog/package.yaml @@ -15,6 +15,7 @@ extra-source-files: dependencies: - base < 5 +- exceptions - free - hedgehog - monad-control @@ -24,6 +25,7 @@ dependencies: - text - time - unliftio +- unliftio-core - wl-pprint-annotated - vty diff --git a/sandwich-hedgehog/sandwich-hedgehog.cabal b/sandwich-hedgehog/sandwich-hedgehog.cabal index 05dae7a..31a289f 100644 --- a/sandwich-hedgehog/sandwich-hedgehog.cabal +++ b/sandwich-hedgehog/sandwich-hedgehog.cabal @@ -43,6 +43,7 @@ library LambdaCase build-depends: base <5 + , exceptions , free , hedgehog , monad-control @@ -52,6 +53,7 @@ library , text , time , unliftio + , unliftio-core , vty , wl-pprint-annotated default-language: Haskell2010 @@ -75,6 +77,7 @@ test-suite sandwich-hedgehog-test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base <5 + , exceptions , free , hedgehog , monad-control @@ -84,6 +87,7 @@ test-suite sandwich-hedgehog-test , text , time , unliftio + , unliftio-core , vty , wl-pprint-annotated default-language: Haskell2010 diff --git a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs b/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs index 519bd45..6bc29c6 100644 --- a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs +++ b/sandwich-hedgehog/src/Test/Sandwich/Hedgehog.hs @@ -56,11 +56,9 @@ module Test.Sandwich.Hedgehog ( ) where import Control.Applicative -import UnliftIO.Exception +import Control.Monad.Catch (MonadCatch) import Control.Monad.Free import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Maybe import Data.String.Interpolate import GHC.Stack @@ -72,6 +70,7 @@ import Hedgehog.Internal.Runner as HR import Hedgehog.Internal.Seed as Seed import Test.Sandwich import Test.Sandwich.Internal +import UnliftIO.Exception #ifndef mingw32_HOST_OS import Test.Sandwich.Hedgehog.Render @@ -97,6 +96,7 @@ data HedgehogParams = HedgehogParams { #endif } deriving (Show) +defaultHedgehogParams :: HedgehogParams defaultHedgehogParams = HedgehogParams { hedgehogSize = Nothing , hedgehogSeed = Nothing @@ -111,41 +111,42 @@ defaultHedgehogParams = HedgehogParams { newtype HedgehogContext = HedgehogContext HedgehogParams deriving Show -hedgehogContext = Label :: Label "hedgehogContext" HedgehogContext +hedgehogContext :: Label "hedgehogContext" HedgehogContext +hedgehogContext = Label type HasHedgehogContext context = HasLabel context "hedgehogContext" HedgehogContext -- | Same as 'introduceHedgehog'' but with default 'HedgehogParams'. -introduceHedgehog :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog :: (MonadIO m) => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog = introduceHedgehog'' "Introduce Hedgehog context" defaultHedgehogParams -- | Same as 'introduceHedgehog''' but with a default message. -introduceHedgehog' :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog' :: (MonadIO m) => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog' = introduceHedgehog'' "Introduce Hedgehog context" -- | Introduce 'HedgehogParams' with configurable message. -introduceHedgehog'' :: (MonadIO m, MonadBaseControl IO m) +introduceHedgehog'' :: (MonadIO m) => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehog'' msg params = introduce msg hedgehogContext (return $ HedgehogContext params) (const $ return ()) -- | Same as 'introduceHedgehogCommandLineOptions'' but with default 'HedgehogParams'. -introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehogCommandLineOptions = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options" defaultHedgehogParams -- | Same as 'introduceHedgehogCommandLineOptions''' but with a default message. -introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () introduceHedgehogCommandLineOptions' = introduceHedgehogCommandLineOptions'' @a "Introduce Hedgehog context with command line options" -- | Introduce 'HedgehogParams' with configurable message, overriding those parameters with any command line options passed. -introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceHedgehogCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => String -> HedgehogParams -> SpecFree (LabelValue "hedgehogContext" HedgehogContext :> context) m () -> SpecFree context m () -introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext (const $ return ()) +introduceHedgehogCommandLineOptions'' msg args = introduce msg hedgehogContext getContext' (const $ return ()) where - getContext = do + getContext' = do clo <- getCommandLineOptions @a return $ HedgehogContext $ addCommandLineOptions clo args @@ -170,7 +171,7 @@ prop msg p = it msg $ do let size = fromMaybe 0 hedgehogSize seed <- maybe Seed.random return hedgehogSeed - finalReport <- checkReport config size seed p $ \progressReport@(Report {..}) -> do + finalReport <- checkReport config size seed p $ \progressReport@(Report {}) -> do -- image <- (return . renderHedgehogToImage) =<< ppProgress Nothing progressReport progress <- renderProgress DisableColor Nothing progressReport diff --git a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog/Render.hs b/sandwich-hedgehog/src/Test/Sandwich/Hedgehog/Render.hs index e171a20..ec2508f 100644 --- a/sandwich-hedgehog/src/Test/Sandwich/Hedgehog/Render.hs +++ b/sandwich-hedgehog/src/Test/Sandwich/Hedgehog/Render.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Hedgehog.Render ( renderHedgehogToImage @@ -11,7 +11,7 @@ module Test.Sandwich.Hedgehog.Render ( import Data.Function import qualified Data.List as L import qualified Data.Text as T -import Graphics.Vty.Attributes +import Graphics.Vty.Attributes hiding (currentAttr) import Graphics.Vty.Image import Hedgehog.Internal.Report import Text.PrettyPrint.Annotated.WL (Doc) @@ -39,7 +39,7 @@ renderHedgehogToTokens doc = joinAdjacentStrings [] = [] splitNewlines :: [Token] -> [Token] - splitNewlines ((Str s):xs) = [Str s | s <- parts, s /= ""] <> splitNewlines xs + splitNewlines ((Str s):xs) = [Str s' | s' <- parts, s' /= ""] <> splitNewlines xs where parts = L.intersperse "\n" $ T.splitOn "\n" s splitNewlines (x:xs) = x : splitNewlines xs splitNewlines [] = [] diff --git a/sandwich-quickcheck/package.yaml b/sandwich-quickcheck/package.yaml index 3913a51..5ea2c0e 100644 --- a/sandwich-quickcheck/package.yaml +++ b/sandwich-quickcheck/package.yaml @@ -23,6 +23,7 @@ dependencies: - text - time - unliftio +- unliftio-core default-extensions: - OverloadedStrings diff --git a/sandwich-quickcheck/sandwich-quickcheck.cabal b/sandwich-quickcheck/sandwich-quickcheck.cabal index b2f60f2..764ac8f 100644 --- a/sandwich-quickcheck/sandwich-quickcheck.cabal +++ b/sandwich-quickcheck/sandwich-quickcheck.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6f60d0ac0ceda196b8e70c79a5da77af10c4d52a9cba4791ffb053f667b9600f +-- hash: c5b28ce371e2107a70ce7c86f1dd571d891de77ba47c359fb9de1030286263aa name: sandwich-quickcheck version: 0.1.0.7 @@ -52,6 +52,7 @@ library , text , time , unliftio + , unliftio-core default-language: Haskell2010 test-suite sandwich-quickcheck-test @@ -81,4 +82,5 @@ test-suite sandwich-quickcheck-test , text , time , unliftio + , unliftio-core default-language: Haskell2010 diff --git a/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs b/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs index 240f123..56ca530 100644 --- a/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs +++ b/sandwich-quickcheck/src/Test/Sandwich/QuickCheck.hs @@ -32,11 +32,9 @@ module Test.Sandwich.QuickCheck ( , modifyMaxShrinks ) where -import UnliftIO.Exception import Control.Monad.Free import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.IO.Unlift import Data.Maybe import qualified Data.Text as T import GHC.Stack @@ -44,11 +42,13 @@ import Test.QuickCheck as QC import Test.QuickCheck.Random as QC import Test.Sandwich import Test.Sandwich.Internal +import UnliftIO.Exception data QuickCheckContext = QuickCheckContext Args deriving Show -quickCheckContext = Label :: Label "quickCheckContext" QuickCheckContext +quickCheckContext :: Label "quickCheckContext" QuickCheckContext +quickCheckContext = Label type HasQuickCheckContext context = HasLabel context "quickCheckContext" QuickCheckContext data QuickCheckException = QuickCheckException @@ -56,43 +56,43 @@ data QuickCheckException = QuickCheckException instance Exception QuickCheckException -- | Same as 'introduceQuickCheck'' but with default args. -introduceQuickCheck :: (MonadIO m, MonadBaseControl IO m) +introduceQuickCheck :: (MonadIO m) => SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () introduceQuickCheck = introduceQuickCheck'' "Introduce QuickCheck context" stdArgs -- | Same as 'introduceQuickCheck''' but with a default message. -introduceQuickCheck' :: (MonadIO m, MonadBaseControl IO m) +introduceQuickCheck' :: (MonadIO m) => Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () introduceQuickCheck' = introduceQuickCheck'' "Introduce QuickCheck context" -- | Introduce QuickCheck args with configurable message. -introduceQuickCheck'' :: (MonadIO m, MonadBaseControl IO m) +introduceQuickCheck'' :: (MonadIO m) => String -> Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () introduceQuickCheck'' msg args = introduce msg quickCheckContext (return $ QuickCheckContext args) (const $ return ()) -- | Same as 'introduceQuickCheckCommandLineOptions'' but with default args. -introduceQuickCheckCommandLineOptions :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceQuickCheckCommandLineOptions :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () introduceQuickCheckCommandLineOptions = introduceQuickCheckCommandLineOptions'' @a "Introduce QuickCheck context with command line options" stdArgs -- | Same as 'introduceQuickCheckCommandLineOptions''' but with a default message. -introduceQuickCheckCommandLineOptions' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceQuickCheckCommandLineOptions' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () introduceQuickCheckCommandLineOptions' = introduceQuickCheckCommandLineOptions'' @a "Introduce QuickCheck context with command line options" -- | Introduce QuickCheck args with configurable message, overriding those args with any command line options passed. -introduceQuickCheckCommandLineOptions'' :: forall a m context. (MonadIO m, MonadBaseControl IO m, HasLabel context "commandLineOptions" (CommandLineOptions a), MonadReader context m) +introduceQuickCheckCommandLineOptions'' :: forall a m context. (MonadIO m, HasLabel context "commandLineOptions" (CommandLineOptions a)) => String -> Args -> SpecFree (LabelValue "quickCheckContext" QuickCheckContext :> context) m () -> SpecFree context m () -introduceQuickCheckCommandLineOptions'' msg args = introduce msg quickCheckContext getContext (const $ return ()) +introduceQuickCheckCommandLineOptions'' msg args = introduce msg quickCheckContext getContext' (const $ return ()) where - getContext = do + getContext' = do clo <- getCommandLineOptions @a return $ QuickCheckContext $ addCommandLineOptions clo args -- | Similar to 'it'. Runs the given prop with QuickCheck using the currently introduced 'Args'. Throws an appropriate exception on failure. -prop :: (HasCallStack, HasQuickCheckContext context, MonadIO m, MonadThrow m, Testable prop) => String -> prop -> Free (SpecCommand context m) () +prop :: (HasCallStack, HasQuickCheckContext context, MonadUnliftIO m, Testable prop) => String -> prop -> Free (SpecCommand context m) () prop msg p = it msg $ do QuickCheckContext args <- getContext quickCheckContext liftIO (quickCheckWithResult (args { QC.chatty = False }) p) >>= \case diff --git a/sandwich-slack/package.yaml b/sandwich-slack/package.yaml index 1afc43a..d539f26 100644 --- a/sandwich-slack/package.yaml +++ b/sandwich-slack/package.yaml @@ -29,6 +29,7 @@ dependencies: - text - time - unliftio +- unliftio-core - vector - wreq diff --git a/sandwich-slack/sandwich-slack.cabal b/sandwich-slack/sandwich-slack.cabal index b8043aa..78d41e4 100644 --- a/sandwich-slack/sandwich-slack.cabal +++ b/sandwich-slack/sandwich-slack.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: edb46ab628d2fbd67e7d2aaf706c9613379157b0dc955e7dc14e7793778b163e +-- hash: fcdf5ae347bc0a4c0ad7121ecde0a71859cb7369fa2fe48e8e16a82ecc86b628 name: sandwich-slack version: 0.1.2.0 @@ -66,6 +66,7 @@ library , text , time , unliftio + , unliftio-core , vector , wreq default-language: Haskell2010 @@ -105,6 +106,7 @@ executable sandwich-slack-exe , text , time , unliftio + , unliftio-core , vector , wreq default-language: Haskell2010 @@ -144,6 +146,7 @@ test-suite sandwich-slack-test , text , time , unliftio + , unliftio-core , vector , wreq default-language: Haskell2010 diff --git a/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs b/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs index 3de99ec..04af4ff 100644 --- a/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs +++ b/sandwich-slack/src/Test/Sandwich/Formatters/Slack.hs @@ -30,9 +30,9 @@ module Test.Sandwich.Formatters.Slack ( import Control.Applicative import Control.Concurrent import Control.Concurrent.STM -import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) import qualified Data.Aeson as A import Data.Foldable @@ -50,6 +50,7 @@ import Test.Sandwich.Formatters.Slack.Internal.Markdown import Test.Sandwich.Formatters.Slack.Internal.ProgressBar import Test.Sandwich.Formatters.Slack.Internal.Types import Test.Sandwich.Internal +import UnliftIO.Exception data SlackFormatter = SlackFormatter { @@ -121,7 +122,7 @@ addCommandLineOptions (CommandLineOptions {optSlackOptions=(CommandLineSlackOpti , slackFormatterMaxMessageSize = optSlackMaxMessageSize <|> slackFormatterMaxMessageSize } -runApp :: (MonadIO m, MonadCatch m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m () +runApp :: (MonadUnliftIO m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m () runApp sf@(SlackFormatter {..}) rts _bc = do startTime <- liftIO getCurrentTime @@ -159,12 +160,13 @@ runApp sf@(SlackFormatter {..}) rts _bc = do loop +publishTree :: SlackFormatter -> M.Map Int (T.Text, Int) -> NominalDiffTime -> [RunNodeWithStatus context Status l t] -> ProgressBarInfo publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi where pbi = ProgressBarInfo { progressBarInfoTopMessage = T.pack <$> (slackFormatterTopMessage sf) , progressBarInfoBottomMessage = Just fullBottomMessage - , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending + failed) / (fromIntegral total))) + , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending' + failed) / (fromIntegral total))) , progressBarInfoAttachments = Nothing , progressBarInfoBlocks = Just $ case slackFormatterMaxFailures sf of Nothing -> mconcat blocks @@ -179,7 +181,7 @@ publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi fullBottomMessage = case runningMessage of Nothing -> bottomMessage Just t -> T.pack t <> "\n" <> bottomMessage - bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|] + bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending'} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|] blocks = catMaybes $ flip concatMap tree $ extractValuesControlRecurse $ \case -- Recurse into grouping nodes, because their failures are actually just derived from child failures @@ -192,12 +194,13 @@ publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi total = countWhere isItBlock tree succeeded = countWhere isSuccessItBlock tree - pending = countWhere isPendingItBlock tree + pending' = countWhere isPendingItBlock tree failed = countWhere isFailedItBlock tree totalRunningTests = countWhere isRunningItBlock tree -- totalNotStartedTests = countWhere isNotStartedItBlock tree +singleFailureBlocks :: SlackFormatter -> M.Map Int (T.Text, Int) -> RunNodeWithStatus context s l t -> FailureReason -> [A.Value] singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [ Just $ markdownSectionWithLines [":red_circle: *" <> label <> "*"] @@ -235,10 +238,13 @@ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [ _ -> Just l label = T.intercalate ", " $ mapMaybe filterFn $ toList $ runTreeAncestors $ runNodeCommon node +extraFailuresBlock :: Int -> A.Value extraFailuresBlock numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]] +markdownBlockWithLines :: [T.Text] -> A.Value markdownBlockWithLines ls = A.object [("type", A.String "mrkdwn"), ("text", A.String $ T.unlines ls)] +markdownSectionWithLines :: [T.Text] -> A.Value markdownSectionWithLines ls = A.object [("type", A.String "section"), ("text", markdownBlockWithLines ls)] addToLastLine :: [T.Text] -> T.Text -> [T.Text] diff --git a/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/Markdown.hs b/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/Markdown.hs index 3ca65cb..27732fe 100644 --- a/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/Markdown.hs +++ b/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/Markdown.hs @@ -19,7 +19,7 @@ toMarkdown (DidNotExpectButGot {..}) = [i|Did not expect *#{failureValue1}*|] toMarkdown (GotException {..}) = case failureMessage of Just msg -> [i|Got exception (_#{msg}_): #{failureException}|] Nothing -> [i|Got exception (no message): #{failureException}|] -toMarkdown (Pending {..}) = "Example was pending" +toMarkdown (Pending {}) = "Example was pending" toMarkdown (GetContextException {..}) = [i|Context exception: #{failureException}|] toMarkdown (GotAsyncException {..}) = case failureMessage of Just msg -> [i|Got async exception (_#{msg}_): #{failureAsyncException}|] @@ -30,6 +30,7 @@ callStackToMarkdown SlackFormatterNoCallStacks _cs = "" callStackToMarkdown (SlackFormatterTopNCallStackFrames n) cs = "\n\n" <> showCallStack (fromCallSiteList $ L.take n $ getCallStack cs) callStackToMarkdown SlackFormatterFullCallStack cs = "\n\n" <> showCallStack cs +showCallStack :: CallStack -> T.Text showCallStack (getCallStack -> rows) = ["> *" <> (T.pack name) <> "*, called at " <> [i|_#{srcLocPackage}_:*#{srcLocFile}*:#{srcLocStartLine}:#{srcLocStartCol}|] | (name, SrcLoc {..}) <- rows] diff --git a/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/ProgressBar.hs b/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/ProgressBar.hs index ca6a1e5..2c58979 100644 --- a/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/ProgressBar.hs +++ b/sandwich-slack/src/Test/Sandwich/Formatters/Slack/Internal/ProgressBar.hs @@ -79,5 +79,5 @@ barSized n = (T.replicate darkBlocks $ T.singleton $ chr 9608) lightBlocks = round $ (100 - n) * multiplier multiplier = 0.5 - roundTo :: (Fractional a, RealFrac a) => Integer -> a -> a + roundTo :: (RealFrac a) => Integer -> a -> a roundTo places num = (fromInteger $ round $ num * (10^places)) / (10.0^^places) diff --git a/sandwich-webdriver/linux-src/Test/Sandwich/WebDriver/Resolution.hs b/sandwich-webdriver/linux-src/Test/Sandwich/WebDriver/Resolution.hs index 17f51ac..7a78376 100644 --- a/sandwich-webdriver/linux-src/Test/Sandwich/WebDriver/Resolution.hs +++ b/sandwich-webdriver/linux-src/Test/Sandwich/WebDriver/Resolution.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Test.Sandwich.WebDriver.Resolution ( getResolution @@ -9,6 +10,7 @@ import Data.Function import qualified Data.List as L import Data.String.Interpolate import qualified Data.Text as T +import GHC.Stack import Safe import System.Directory import System.Exit @@ -27,14 +29,14 @@ import Text.Regex -- https://github.com/rr-/screeninfo/blob/master/screeninfo/enumerators/xinerama.py -- but again, that would require users to install those libraries. xrandr itself seems like an easier -- dependency. -getResolution :: IO (Int, Int, Int, Int) +getResolution :: (HasCallStack) => IO (Int, Int, Int, Int) getResolution = getResolution' Nothing getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int) getResolutionForDisplay n = getResolution' (Just [("DISPLAY", ":" <> show n)]) -- | Note: this doesn't pick up display scaling on Ubuntu 20.04. -getResolution' :: Maybe [(String, String)] -> IO (Int, Int, Int, Int) +getResolution' :: (HasCallStack) => Maybe [(String, String)] -> IO (Int, Int, Int, Int) getResolution' xrandrEnv = do xrandrPath <- findExecutable "xrandr" >>= \case Just x -> return x diff --git a/sandwich-webdriver/package.yaml b/sandwich-webdriver/package.yaml index c97462c..486e1b9 100644 --- a/sandwich-webdriver/package.yaml +++ b/sandwich-webdriver/package.yaml @@ -42,6 +42,7 @@ dependencies: - time - transformers - unliftio +- unliftio-core - unordered-containers - vector - webdriver diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal index d45d371..69fabce 100644 --- a/sandwich-webdriver/sandwich-webdriver.cabal +++ b/sandwich-webdriver/sandwich-webdriver.cabal @@ -91,6 +91,7 @@ library , time , transformers , unliftio + , unliftio-core , unordered-containers , vector , webdriver @@ -168,6 +169,7 @@ executable sandwich-webdriver-exe , time , transformers , unliftio + , unliftio-core , unordered-containers , vector , webdriver @@ -246,6 +248,7 @@ test-suite sandwich-webdriver-test , time , transformers , unliftio + , unliftio-core , unordered-containers , vector , webdriver diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index fae285e..1caafee 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -35,7 +35,6 @@ module Test.Sandwich.WebDriver ( ) where import Control.Applicative -import Control.Concurrent.MVar.Lifted import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader @@ -54,6 +53,7 @@ import Test.Sandwich.WebDriver.Types import qualified Test.WebDriver as W import qualified Test.WebDriver.Config as W import qualified Test.WebDriver.Session as W +import UnliftIO.MVar -- | This is the main 'introduce' method for creating a WebDriver. @@ -81,7 +81,7 @@ allocateWebDriver' runRoot wdOptions = do runNoLoggingT $ startWebDriver wdOptions runRoot -- | Clean up the given WebDriver. -cleanupWebDriver :: (HasBaseContext context, BaseMonad m) => WebDriver -> ExampleT context m () +cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m () cleanupWebDriver sess = do closeAllSessions sess stopWebDriver sess @@ -94,7 +94,7 @@ cleanupWebDriver' sess = do stopWebDriver sess -- | Run a given example using a given Selenium session. -withSession :: forall m context a. WebDriverMonad m context => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a +withSession :: forall m context a. (WebDriverMonad m context) => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a withSession session (ExampleT readerMonad) = do WebDriver {..} <- getContext webdriver -- Create new session if necessary (this can throw an exception) @@ -124,7 +124,7 @@ withSession2 :: WebDriverMonad m context => ExampleT (ContextWithSession context withSession2 = withSession "session2" -- | Get all existing session names -getSessions :: (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriver" WebDriver) => m [Session] +getSessions :: (MonadReader context m, WebDriverMonad m context) => m [Session] getSessions = do WebDriver {..} <- getContext webdriver M.keys <$> liftIO (readMVar wdSessionMap) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs index c59ca7c..b1f48fb 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs @@ -3,12 +3,10 @@ module Test.Sandwich.WebDriver.Internal.Action where import Control.Monad -import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Map as M import Data.String.Interpolate import GHC.Stack diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs index 9e8a96d..4888e7b 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs @@ -12,11 +12,9 @@ module Test.Sandwich.WebDriver.Internal.Binaries ( import Control.Exception import Control.Monad -import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except import Data.String.Interpolate import qualified Data.Text as T diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs index 7f6efe5..ae8434d 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs @@ -91,7 +91,7 @@ getChromeDriverVersion' (ChromeVersion (w, x, y, z)) (do result :: T.Text <- (TL.toStrict . TL.decodeUtf8) <$> simpleHttp url case T.splitOn "." result of - [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ ChromeDriverVersionTuple (w, x, y, z) + [tReadMay -> Just w', tReadMay -> Just x', tReadMay -> Just y', tReadMay -> Just z'] -> return $ Right $ ChromeDriverVersionTuple (w', x', y', z') _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|] ) | otherwise = do @@ -107,15 +107,15 @@ getChromeDriverVersion' (ChromeVersion (w, x, y, z)) let matchingVersions = [v | v@(Version {..}) <- versions response , [i|#{w}.#{x}.#{y}.|] `T.isPrefixOf` version] - let exactMatch = headMay [x | x@(Version {..}) <- matchingVersions - , [i|#{w}.#{x}.#{y}.#{z}|] == version] + let exactMatch = headMay [v | v@(Version {..}) <- matchingVersions + , [i|#{w}.#{x}.#{y}.#{z}|] == version] let versionList :: [Version] - versionList = (case exactMatch of Nothing -> id; Just x -> (x :)) matchingVersions + versionList = (case exactMatch of Nothing -> id; Just v -> (v :)) matchingVersions case headMay (mapMaybe extractSuitableChromeDriver versionList) of Nothing -> return $ Left [i|Couldn't find chromedriver associated with any Chrome release|] - Just (tup, url) -> return $ Right $ ChromeDriverVersionExactUrl tup url + Just (tup, url') -> return $ Right $ ChromeDriverVersionExactUrl tup url' ) extractSuitableChromeDriver :: Version -> Maybe ((Int, Int, Int, Int), Text) @@ -154,4 +154,5 @@ getChromeDriverDownloadUrl (ChromeDriverVersionExactUrl _ url) _ = url -- * Util +tReadMay :: T.Text -> Maybe Int tReadMay = readMay . T.unpack diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectFirefox.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectFirefox.hs index 2403ba8..3f896c9 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectFirefox.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectFirefox.hs @@ -74,4 +74,5 @@ getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Windows = [i|https://gi -- * Util +tReadMay :: T.Text -> Maybe Int tReadMay = readMay . T.unpack diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs index aacbe08..61939f2 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs @@ -8,7 +8,6 @@ module Test.Sandwich.WebDriver.Internal.Screenshots where import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Control.Monad.IO.Unlift import qualified Data.Map as M import Data.String.Interpolate import qualified Data.Text as T @@ -26,5 +25,5 @@ saveScreenshots screenshotName (WebDriver {..}) resultsDir = do forM_ (M.toList sessionMap) $ \(browser, sess) -> handle (\(e :: HttpException) -> case e of (HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|] - e -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e}'|]) + e' -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e'}'|]) (runWD sess $ saveScreenshot $ resultsDir [i|#{browser}_#{screenshotName}.png|]) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index 83a4626..6c81edf 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -13,6 +13,7 @@ import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger +import Control.Monad.Trans.Control (MonadBaseControl) import Control.Retry import qualified Data.Aeson as A import Data.Default @@ -57,7 +58,7 @@ fromText = id #endif -type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m) +type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m) -- | Spin up a Selenium WebDriver and create a WebDriver startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver @@ -117,6 +118,9 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do liftIO $ createDirectoryIfMissing True webdriverProcessRoot startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv +startWebDriver' :: ( + MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m + ) => WdOptions -> T.Text -> [Char] -> [Char] -> [Char] -> [String] -> Maybe XvfbSession -> Maybe [(String, String)] -> m WebDriver startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do port <- liftIO findFreePortOrException let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath @@ -150,7 +154,7 @@ startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriver t | readyMessage `T.isInfixOf` t -> return True _ -> return False unless success $ liftIO $ do - interruptProcessGroupOf p >> waitForProcess p + _ <- interruptProcessGroupOf p >> waitForProcess p error [i|Selenium server failed to start after 60 seconds|] capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities' @@ -211,18 +215,18 @@ configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps (w, h) = fromMaybe (1920, 1080) headlessResolution -- | Add headless configuration to the Firefox capabilities -configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps }) +configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps }) where additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac - Just i -> let ffOptions' = snd (ac !! i) - & ensureKeyExists "args" (A.Array []) - & ((key "args" . _Array) %~ addHeadlessArg) in + Just i' -> let ffOptions' = snd (ac !! i') + & ensureKeyExists "args" (A.Array []) + & ((key "args" . _Array) %~ addHeadlessArg) in L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac) ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value - ensureKeyExists key _ val@(A.Object (HM.lookup (fromText key) -> Just _)) = val - ensureKeyExists key defaultVal (A.Object m@(HM.lookup (fromText key) -> Nothing)) = A.Object (HM.insert (fromText key) defaultVal m) + ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val + ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m) ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists" addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value @@ -233,6 +237,9 @@ configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mod configureHeadlessCapabilities _ _ browser = return browser +configureDownloadCapabilities :: ( + MonadIO m, MonadBaseControl IO m + ) => [Char] -> W.Capabilities -> m W.Capabilities configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do case ffProfile of Nothing -> return () diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs index 5184f6b..103f2d3 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs @@ -25,8 +25,11 @@ import qualified Test.WebDriver.Session as W type Session = String -- * Labels -webdriver = Label :: Label "webdriver" WebDriver -webdriverSession = Label :: Label "webdriverSession" WebDriverSession +webdriver :: Label "webdriver" WebDriver +webdriver = Label + +webdriverSession :: Label "webdriverSession" WebDriverSession +webdriverSession = Label type WebDriverContext context wd = (HasLabel context "webdriver" WebDriver, W.WebDriver (ExampleT context wd)) @@ -136,6 +139,7 @@ data HeadlessConfig = HeadlessConfig { } -- | Default headless config. +defaultHeadlessConfig :: HeadlessConfig defaultHeadlessConfig = HeadlessConfig Nothing data XvfbConfig = XvfbConfig { @@ -147,6 +151,7 @@ data XvfbConfig = XvfbConfig { } -- | Default Xvfb settings. +defaultXvfbConfig :: XvfbConfig defaultXvfbConfig = XvfbConfig Nothing False -- | The default 'WdOptions' object. @@ -213,6 +218,7 @@ instance Show XvfbSession where -- * Video stuff -- | Default options for fast X11 video recording. +fastX11VideoOptions :: [String] fastX11VideoOptions = ["-an" , "-r", "30" , "-vcodec" @@ -221,6 +227,7 @@ fastX11VideoOptions = ["-an" , "-threads", "0"] -- | Default options for quality X11 video recording. +qualityX11VideoOptions :: [String] qualityX11VideoOptions = ["-an" , "-r", "30" , "-vcodec", "libx264" @@ -229,6 +236,7 @@ qualityX11VideoOptions = ["-an" , "-threads", "0"] -- | Default options for AVFoundation recording (for Darwin). +defaultAvfoundationOptions :: [String] defaultAvfoundationOptions = ["-r", "30" , "-an" , "-vcodec", "libxvid" @@ -236,6 +244,7 @@ defaultAvfoundationOptions = ["-r", "30" , "-threads", "0"] -- | Default options for gdigrab recording (for Windows). +defaultGdigrabOptions :: [String] defaultGdigrabOptions = ["-framerate", "30"] data VideoSettings = VideoSettings { @@ -252,6 +261,7 @@ data VideoSettings = VideoSettings { } -- | Default video settings. +defaultVideoSettings :: VideoSettings defaultVideoSettings = VideoSettings { x11grabOptions = fastX11VideoOptions , avfoundationOptions = defaultAvfoundationOptions diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs index 0959ba4..201b28d 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs @@ -3,9 +3,7 @@ module Test.Sandwich.WebDriver.Internal.Util where import Control.Monad -import Control.Monad.IO.Class import Control.Monad.IO.Unlift -import Control.Monad.Trans.Control (MonadBaseControl) import Data.String.Interpolate import qualified Data.Text as T import System.Directory diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs index 6984ffb..a5c1f89 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Video.hs @@ -17,6 +17,7 @@ getMacScreenNumber = undefined #endif +getVideoArgs :: (MonadIO m) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m CreateProcess getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do #ifdef linux_HOST_OS displayNum <- case maybeXvfbSession of diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs index fa8aef1..6ac2f31 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Sandwich.WebDriver.Types ( ExampleWithWebDriver @@ -23,8 +24,9 @@ module Test.Sandwich.WebDriver.Types ( , WebDriverSessionMonad ) where -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl) import Data.IORef @@ -49,7 +51,7 @@ instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession) => W. liftIO $ writeIORef sessVar sess -- Implementation copied from that of the WD monad implementation -instance (MonadIO m, MonadThrow m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where +instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where doCommand method path args = WI.mkRequest method path args >>= WI.sendHTTPRequest >>= either throwIO return @@ -64,7 +66,7 @@ hoistExample :: ExampleT context IO a -> ExampleT (ContextWithSession context) I hoistExample (ExampleT r) = ExampleT $ transformContext r where transformContext = withReaderT (\(_ :> ctx) -> ctx) -type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadIO m, MonadBaseControl IO m) +type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadUnliftIO m, MonadBaseControl IO m) type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriverSession" WebDriverSession) -type BaseMonad m = (HasCallStack, MonadIO m, MonadCatch m, MonadBaseControl IO m, MonadMask m) +type BaseMonad m = (HasCallStack, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m) type BaseMonadContext m context = (BaseMonad m, HasBaseContext context) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs index d7dd13e..97eecdf 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs @@ -19,6 +19,7 @@ module Test.Sandwich.WebDriver.Video ( ) where import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) import Control.Monad.Reader import Data.String.Interpolate @@ -36,11 +37,11 @@ import Test.WebDriver.Commands import UnliftIO.Exception -type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context) +type BaseVideoConstraints context m = (MonadLoggerIO m, MonadUnliftIO m, MonadReader context m, HasWebDriverContext context) -- | Wrapper around 'startVideoRecording' which uses the full screen dimensions. startFullScreenVideoRecording :: ( - BaseVideoConstraints context m, MonadMask m + BaseVideoConstraints context m ) => FilePath -> VideoSettings -> m ProcessHandle startFullScreenVideoRecording path videoSettings = do sess <- getContext webdriver @@ -54,7 +55,7 @@ startFullScreenVideoRecording path videoSettings = do -- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser. startBrowserVideoRecording :: ( - BaseVideoConstraints context m, MonadThrow m, HasWebDriverSessionContext context, W.WebDriver m + BaseVideoConstraints context m, W.WebDriver m ) => FilePath -> VideoSettings -> m ProcessHandle startBrowserVideoRecording path videoSettings = do (x, y) <- getWindowPos @@ -86,7 +87,7 @@ startVideoRecording path (width, height, x, y) vs = do -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'. endVideoRecording :: ( - MonadLoggerIO m, MonadCatch m + MonadLoggerIO m, MonadUnliftIO m ) => ProcessHandle -> m () endVideoRecording p = do catchAny (liftIO $ interruptProcessGroupOf p) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs index 4be13a0..6f7b6f0 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs @@ -1,5 +1,5 @@ --- | Functions for manipulating browser windows. +-- | Functions for manipulating browser windows. module Test.Sandwich.WebDriver.Windows ( -- * Window positioning @@ -11,9 +11,7 @@ module Test.Sandwich.WebDriver.Windows ( , getScreenResolution ) where -import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader import Data.Bits as B import Data.Maybe @@ -23,11 +21,10 @@ import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Resolution import Test.WebDriver import qualified Test.WebDriver.Class as W -import UnliftIO.Exception -- | Position the window on the left 50% of the screen. -setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd () +setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd () setWindowLeftSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -38,7 +35,7 @@ setWindowLeftSide = do setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height) -- | Position the window on the right 50% of the screen. -setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd () +setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd () setWindowRightSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -50,7 +47,7 @@ setWindowRightSide = do setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height) -- | Fullscreen the browser window. -setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd () +setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd) => wd () setWindowFullScreen = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -61,7 +58,7 @@ setWindowFullScreen = do setWindowSize (fromIntegral width, fromIntegral height) -- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.) -getScreenResolution :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int) +getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int) getScreenResolution (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of Nothing -> liftIO getResolution Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum diff --git a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs b/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs index 0568159..f3baa28 100644 --- a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +++ b/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb ( @@ -13,7 +13,6 @@ import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Retry import qualified Data.List as L import Data.Maybe