diff --git a/sandwich-contexts/package.yaml b/sandwich-contexts/package.yaml index 807ea629..8c01fa5e 100644 --- a/sandwich-contexts/package.yaml +++ b/sandwich-contexts/package.yaml @@ -39,6 +39,8 @@ library: - Test.Sandwich.Contexts.Nix - Test.Sandwich.Contexts.PostgreSQL - Test.Sandwich.Contexts.Waits + + - Test.Sandwich.Contexts.Util.Ports dependencies: - aeson - bytestring diff --git a/sandwich-contexts/sandwich-contexts.cabal b/sandwich-contexts/sandwich-contexts.cabal index 0ce49079..c903fd46 100644 --- a/sandwich-contexts/sandwich-contexts.cabal +++ b/sandwich-contexts/sandwich-contexts.cabal @@ -21,6 +21,7 @@ library Test.Sandwich.Contexts.Nix Test.Sandwich.Contexts.PostgreSQL Test.Sandwich.Contexts.Waits + Test.Sandwich.Contexts.Util.Ports other-modules: Test.Sandwich.Contexts.FakeSmtpServer.Derivation Test.Sandwich.Contexts.ReverseProxy.TCP @@ -28,7 +29,6 @@ library Test.Sandwich.Contexts.Util.Container Test.Sandwich.Contexts.Util.Exception Test.Sandwich.Contexts.Util.Nix - Test.Sandwich.Contexts.Util.Ports Test.Sandwich.Contexts.Util.SocketUtil Test.Sandwich.Contexts.Util.UUID Paths_sandwich_contexts diff --git a/sandwich-webdriver/package.yaml b/sandwich-webdriver/package.yaml index 5c45b4cb..5ad7b39a 100644 --- a/sandwich-webdriver/package.yaml +++ b/sandwich-webdriver/package.yaml @@ -36,6 +36,7 @@ dependencies: - retry - safe - sandwich >= 0.1.0.3 +- sandwich-contexts - string-interpolate - text - time diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal index 4061dcb9..18e15e95 100644 --- a/sandwich-webdriver/sandwich-webdriver.cabal +++ b/sandwich-webdriver/sandwich-webdriver.cabal @@ -35,7 +35,6 @@ library Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform Test.Sandwich.WebDriver.Internal.Capabilities - Test.Sandwich.WebDriver.Internal.Ports Test.Sandwich.WebDriver.Internal.Screenshots Test.Sandwich.WebDriver.Internal.StartWebDriver Test.Sandwich.WebDriver.Internal.Types @@ -85,6 +84,7 @@ library , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , string-interpolate , text , time @@ -163,6 +163,7 @@ executable sandwich-webdriver-exe , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , sandwich-webdriver , string-interpolate , text @@ -241,6 +242,7 @@ test-suite sandwich-webdriver-test , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , sandwich-webdriver , string-interpolate , text diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index 1caafeea..2de6eb43 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -43,6 +43,8 @@ import qualified Data.Map as M import Data.Maybe 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.Class import Test.Sandwich.WebDriver.Config @@ -58,7 +60,10 @@ import UnliftIO.MVar -- | This is the main 'introduce' method for creating a WebDriver. introduceWebDriver :: (BaseMonadContext m context) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m () -introduceWebDriver wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver +introduceWebDriver wdOptions = undefined -- introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver + +introduceWebDriverViaNix :: (BaseMonadContext m context, HasNixContext context) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m () +introduceWebDriverViaNix wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver -- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'. introduceWebDriverOptions :: forall a context m. (BaseMonadContext m context, HasCommandLineOptions context a) @@ -69,7 +74,7 @@ introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" we allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions) -- | Allocate a WebDriver using the given options. -allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver +allocateWebDriver :: (BaseMonad m, HasBaseContext context, MonadReader context m) => WdOptions -> ExampleT context m WebDriver allocateWebDriver wdOptions = do debug "Beginning allocateWebDriver" dir <- fromMaybe "/tmp" <$> getCurrentFolder diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs index b1f48fb4..0af7fd8d 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs @@ -42,7 +42,10 @@ closeAllSessions :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => WebDriver closeAllSessions = closeAllSessionsExcept [] -- | Close the current session -closeCurrentSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m () +closeCurrentSession :: ( + HasCallStack, MonadLogger m, MonadUnliftIO m + , MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession + ) => m () closeCurrentSession = do webDriver <- getContext webdriver (session, _) <- getContext webdriverSession diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs index d95b9eae..ed24ceab 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedLists #-} --- | module Test.Sandwich.WebDriver.Internal.Capabilities ( -- * Chrome diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs deleted file mode 100644 index ebdfc6d7..00000000 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, LambdaCase #-} - -module Test.Sandwich.WebDriver.Internal.Ports ( - findFreePortOrException - ) where - -import Control.Exception -import Control.Retry -import Data.Maybe -import Data.String.Interpolate -import qualified Data.Text as T -import Network.Socket -import System.Random (randomRIO) -import Test.Sandwich.WebDriver.Internal.Util - -firstUserPort :: PortNumber -firstUserPort = 1024 - -highestPort :: PortNumber -highestPort = 65535 - --- |Find an unused port in a given range -findFreePortInRange' :: RetryPolicy -> IO PortNumber -> IO (Maybe PortNumber) -findFreePortInRange' policy getAcceptableCandidate = retrying policy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange'') - where - findFreePortInRange'' :: IO (Maybe PortNumber) - findFreePortInRange'' = do - candidate <- getAcceptableCandidate - catch (tryOpenAndClosePort candidate >> return (Just candidate)) (\(_ :: SomeException) -> return Nothing) - where - tryOpenAndClosePort :: PortNumber -> IO PortNumber - tryOpenAndClosePort port = do - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - let hostAddress = tupleToHostAddress (127, 0, 0, 1) - bind sock (SockAddrInet port hostAddress) - close sock - return $ fromIntegral port - -findFreePortInRange :: IO PortNumber -> IO (Maybe PortNumber) -findFreePortInRange = findFreePortInRange' (limitRetries 50) - --- | Find an unused port in the ephemeral port range. --- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers --- This works without a timeout since there should always be a port in the somewhere; --- it might be advisable to wrap in a timeout anyway. -findFreePort :: IO (Maybe PortNumber) -findFreePort = findFreePortInRange getNonEphemeralCandidate - -findFreePortOrException :: IO PortNumber -findFreePortOrException = findFreePort >>= \case - Just port -> return port - Nothing -> error "Couldn't find free port" - --- * Util - -getNonEphemeralCandidate :: IO PortNumber -getNonEphemeralCandidate = do - (ephemeralStart, ephemeralEnd) <- getEphemeralPortRange >>= \case - Left _ -> return (49152, 65535) - Right range -> return range - - let numBelow = ephemeralStart - firstUserPort - let numAbove = highestPort - ephemeralEnd - - u :: Double <- randomRIO (0, 1) - - let useLowerRange = u < ((fromIntegral numBelow) / (fromIntegral numBelow + fromIntegral numAbove)) - - if | useLowerRange -> fromInteger <$> randomRIO (fromIntegral firstUserPort, fromIntegral ephemeralStart) - | otherwise -> fromInteger <$> randomRIO (fromIntegral ephemeralEnd, fromIntegral highestPort) - -getEphemeralPortRange :: IO (Either T.Text (PortNumber, PortNumber)) -getEphemeralPortRange = leftOnException' $ do - contents <- readFile "/proc/sys/net/ipv4/ip_local_port_range" - case fmap read (words contents) of - [p1, p2] -> return (p1, p2) - _ -> error [i|Unexpected contents: '#{contents}'|] diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index 6c81edf8..9dc99d42 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -13,6 +14,7 @@ import Control.Monad.Catch (MonadMask) 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 Control.Retry import qualified Data.Aeson as A @@ -32,10 +34,11 @@ import System.FilePath import System.IO import System.Process import Test.Sandwich +import Test.Sandwich.Contexts.Files +import Test.Sandwich.Contexts.Util.Ports (findFreePortOrException) import Test.Sandwich.Util.Process import Test.Sandwich.WebDriver.Internal.Binaries import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion) -import Test.Sandwich.WebDriver.Internal.Ports import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W @@ -61,7 +64,7 @@ fromText = id 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 +startWebDriver :: (Constraints m, MonadReader context m, HasFile context "java") => WdOptions -> FilePath -> m WebDriver startWebDriver wdOptions@(WdOptions {..}) runRoot = do -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID @@ -120,11 +123,16 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do startWebDriver' :: ( MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m + , MonadReader context m, HasFile context "java" ) => 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 + javaPath <- askFile @"java" + port <- liftIO findFreePortOrException - let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath - , "-port", show port])) { env = javaEnv } + let wdCreateProcess = ( + proc javaPath (driverArgs <> ["-jar", seleniumPath + , "-port", show port]) + ) { env = javaEnv } -- Open output handles let seleniumOutPath = webdriverRoot seleniumOutFileName @@ -237,6 +245,8 @@ configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mod configureHeadlessCapabilities _ _ browser = return browser +-- | Configure download capabilities to set the download directory and disable prompts +-- (since you can't test download prompts using Selenium) configureDownloadCapabilities :: ( MonadIO m, MonadBaseControl IO m ) => [Char] -> W.Capabilities -> m W.Capabilities diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs index e6f22e02..2f5ebb67 100644 --- a/sandwich/src/Test/Sandwich/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/ArgParsing.hs @@ -191,12 +191,12 @@ commandLineSlackOptions maybeInternal = CommandLineSlackOptions -- * Parse command line args -parseCommandLineArgs :: forall a. Parser a -> TopSpecWithOptions' a -> IO (CommandLineOptions a) +parseCommandLineArgs :: forall a. Typeable a => Parser a -> TopSpecWithOptions' a -> IO (CommandLineOptions a) parseCommandLineArgs parser spec = do (clo, _, _) <- parseCommandLineArgs' parser spec return clo -parseCommandLineArgs' :: forall a. Parser a -> TopSpecWithOptions' a -> IO ( +parseCommandLineArgs' :: forall a. Typeable a => Parser a -> TopSpecWithOptions' a -> IO ( CommandLineOptions a , Mod FlagFields (Maybe IndividualTestModule) -> Parser (Maybe IndividualTestModule) , [(NodeModuleInfo, T.Text)]