diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/Files.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/Files.hs index f0080ba..101b063 100644 --- a/sandwich-contexts/lib/Test/Sandwich/Contexts/Files.hs +++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/Files.hs @@ -44,6 +44,7 @@ module Test.Sandwich.Contexts.Files ( -- * Introduce file from a Nix package , introduceFileViaNixPackage , introduceFileViaNixPackage' + , introduceFileViaNixPackage'' , getFileViaNixPackage -- * Introduce a binary from a Nix derivation @@ -54,12 +55,17 @@ module Test.Sandwich.Contexts.Files ( -- * Introduce a file from a Nix derivation , introduceFileViaNixDerivation , introduceFileViaNixDerivation' + , introduceFileViaNixDerivation'' , getFileViaNixDerivation -- * Get a file , askFile , askFile' + -- * Helpers for file-finding callbacks + , defaultFindFile + , findFirstFile + -- * Low-level , mkFileLabel @@ -70,6 +76,7 @@ module Test.Sandwich.Contexts.Files ( import Control.Monad.IO.Unlift import Control.Monad.Logger +import Control.Monad.Trans.Except import Data.String.Interpolate import GHC.TypeLits import Relude @@ -153,6 +160,17 @@ type NixPackageName = Text -- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope. -- It's recommended to use this with -XTypeApplications. introduceFileViaNixPackage :: forall a context m. ( + HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a + ) => + -- | Nix package name which contains the desired file. + -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'. + NixPackageName + -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () + -> SpecFree context m () +introduceFileViaNixPackage name = introduceFileViaNixPackage' @a name (defaultFindFile (symbolVal (Proxy @a))) + +-- | Same as 'introduceFileViaNixPackage', but allows you to customize the search callback. +introduceFileViaNixPackage' :: forall a context m. ( HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a ) => -- | Nix package name which contains the desired file. @@ -165,10 +183,10 @@ introduceFileViaNixPackage :: forall a context m. ( -> (FilePath -> IO FilePath) -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () -> SpecFree context m () -introduceFileViaNixPackage = introduceFileViaNixPackage' (Proxy @a) +introduceFileViaNixPackage' = introduceFileViaNixPackage'' (Proxy @a) --- | Same as 'introduceFileViaNixPackage', but allows passing a 'Proxy'. -introduceFileViaNixPackage' :: forall a context m. ( +-- | Same as 'introduceFileViaNixPackage'', but allows passing a 'Proxy'. +introduceFileViaNixPackage'' :: forall a context m. ( HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a ) => Proxy a -- | Nix package name which contains the desired file. @@ -180,7 +198,7 @@ introduceFileViaNixPackage' :: forall a context m. ( -> (FilePath -> IO FilePath) -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () -> SpecFree context m () -introduceFileViaNixPackage' proxy packageName tryFindFile = introduce [i|#{symbolVal proxy} (file via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ()) +introduceFileViaNixPackage'' proxy packageName tryFindFile = introduce [i|#{symbolVal proxy} (file via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ()) where alloc = buildNixSymlinkJoin [packageName] >>= \p -> EnvironmentFile <$> liftIO (tryFindFile p) @@ -285,6 +303,16 @@ getBinaryViaNixDerivation derivation = -- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope. -- It's recommended to use this with -XTypeApplications. introduceFileViaNixDerivation :: forall a context m. ( + HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a + ) => + -- | Nix derivation as a string. + Text + -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () + -> SpecFree context m () +introduceFileViaNixDerivation derivation = introduceFileViaNixDerivation' @a derivation (defaultFindFile (symbolVal (Proxy @a))) + +-- | Same as 'introduceFileViaNixDerivation', but allows configuring the file finding callback. +introduceFileViaNixDerivation' :: forall a context m. ( HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a ) => -- | Nix derivation as a string. @@ -293,10 +321,10 @@ introduceFileViaNixDerivation :: forall a context m. ( -> (FilePath -> IO FilePath) -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () -> SpecFree context m () -introduceFileViaNixDerivation = introduceFileViaNixDerivation' (Proxy @a) +introduceFileViaNixDerivation' = introduceFileViaNixDerivation'' (Proxy @a) --- | Same as 'introduceFileViaNixDerivation', but allows passing a 'Proxy'. -introduceFileViaNixDerivation' :: forall a context m. ( +-- | Same as 'introduceFileViaNixDerivation'', but allows passing a 'Proxy'. +introduceFileViaNixDerivation'' :: forall a context m. ( HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a ) => Proxy a -- | Nix derivation as a string. @@ -305,7 +333,7 @@ introduceFileViaNixDerivation' :: forall a context m. ( -> (FilePath -> IO FilePath) -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () -> SpecFree context m () -introduceFileViaNixDerivation' proxy derivation tryFindFile = introduce [i|#{symbolVal proxy} (file via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ()) +introduceFileViaNixDerivation'' proxy derivation tryFindFile = introduce [i|#{symbolVal proxy} (file via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ()) where alloc = EnvironmentFile <$> (buildNixCallPackageDerivation derivation >>= liftIO . tryFindFile) @@ -327,3 +355,25 @@ tryFindBinary binaryName env = do findExecutablesInDirectories [env "bin"] binaryName >>= \case (x:_) -> return $ EnvironmentFile x _ -> expectationFailure [i|Couldn't find binary '#{binaryName}' in #{env "bin"}|] + +-- | Find a file whose name exactly matches a string, using 'findFirstFile'. +-- This calls 'takeFileName', so it only matches against the name, not the relative path. +defaultFindFile :: String -> FilePath -> IO FilePath +defaultFindFile name root = findFirstFile (\x -> return (takeFileName x == name)) root + +-- | Find the first file under the given directory (recursively) which matches the predicate. +-- Note that the callback receives the full relative path to the file from the root dir. +-- Throws using 'expectationFailure' when the file is not found. +findFirstFile :: (FilePath -> IO Bool) -> FilePath -> IO FilePath +findFirstFile predicate dir = runExceptT (go dir) >>= \case + Left x -> return x + Right () -> expectationFailure [i|Couldn't find file in '#{dir}'|] + where + go :: FilePath -> ExceptT FilePath IO () + go currentDir = do + contents <- liftIO $ listDirectory currentDir + forM_ contents $ \name -> do + let path = currentDir name + doesDirectoryExist path >>= \case + True -> go path + False -> whenM (liftIO $ predicate path) (throwE path) diff --git a/sandwich-contexts/package.yaml b/sandwich-contexts/package.yaml index 1ad018f..84ab5d7 100644 --- a/sandwich-contexts/package.yaml +++ b/sandwich-contexts/package.yaml @@ -67,6 +67,7 @@ library: - temporary - text - time + - transformers - unix - unliftio-core - vector diff --git a/sandwich-contexts/sandwich-contexts.cabal b/sandwich-contexts/sandwich-contexts.cabal index 57dec9d..ef77285 100644 --- a/sandwich-contexts/sandwich-contexts.cabal +++ b/sandwich-contexts/sandwich-contexts.cabal @@ -75,6 +75,7 @@ library , temporary , text , time + , transformers , unix , unliftio , unliftio-core diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index 79720ce..b407de3 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -40,10 +40,10 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader import Data.IORef +import qualified Data.List as L import qualified Data.Map as M import Data.Maybe import Data.String.Interpolate -import qualified Data.Text as T import Test.Sandwich import Test.Sandwich.Contexts.Files import Test.Sandwich.Contexts.Nix @@ -60,7 +60,6 @@ import qualified Test.WebDriver as W import qualified Test.WebDriver.Config as W import qualified Test.WebDriver.Session as W import UnliftIO.MVar -import UnliftIO.Process -- | This is the main 'introduce' method for creating a WebDriver. @@ -73,7 +72,7 @@ introduceWebDriverViaNix :: forall m context. ( BaseMonadContext m context, HasSomeCommandLineOptions context, HasNixContext context ) => WdOptions -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m () introduceWebDriverViaNix wdOptions = - introduceFileViaNixPackage @"selenium.jar" "selenium-server-standalone" tryFindSeleniumJar + introduceFileViaNixPackage' @"selenium.jar" "selenium-server-standalone" (findFirstFile (return . (".jar" `L.isSuffixOf`))) . introduceBinaryViaNixPackage @"java" "jre" . introduceBrowserDependenciesViaNix . introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver @@ -82,9 +81,6 @@ introduceWebDriverViaNix wdOptions = clo <- getSomeCommandLineOptions allocateWebDriver (addCommandLineOptionsToWdOptions clo wdOptions) - tryFindSeleniumJar :: FilePath -> IO FilePath - tryFindSeleniumJar path = (T.unpack . T.strip . T.pack) <$> readCreateProcess (proc "find" [path, "-name", "*.jar"]) "" - -- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'. introduceWebDriverOptions :: forall context m. ( BaseMonadContext m context, HasSomeCommandLineOptions context diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs index e26e288..c94e042 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs @@ -7,16 +7,17 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader +import qualified Data.List as L import Data.String.Interpolate import qualified Data.Text as T import GHC.Stack import System.Directory import Test.Sandwich +import Test.Sandwich.Contexts.Files import Test.Sandwich.Contexts.Nix import Test.Sandwich.WebDriver.Internal.Binaries.Common import Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types import Test.Sandwich.WebDriver.Internal.Util -import UnliftIO.Process type Constraints m = ( @@ -50,11 +51,8 @@ obtainSelenium (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case False -> expectationFailure [i|Path '#{path}' didn't exist|] True -> return path obtainSelenium (UseSeleniumFromNixpkgs nixContext) = do - env <- buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] - liftIO (tryFindSeleniumJar env) - where - tryFindSeleniumJar :: FilePath -> IO FilePath - tryFindSeleniumJar path = (T.unpack . T.strip . T.pack) <$> readCreateProcess (proc "find" [path, "-name", "*.jar"]) "" + buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] >>= + liftIO . findFirstFile (return . (".jar" `L.isSuffixOf`)) -- * Lower level helpers