Files.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-|

This module contains tools for introducing files and making them available to tests. It uses type-level strings, and is mostly intended to be used with -XTypeApplications.

For example:

@
introduceFile \@"grep" "\/path\/to\/grep" $ do
  it "uses grep for something" $ do
    grep <- askFile \@"grep"
    results <- readCreateProcess (proc grep ["foo"]) ""
    todo -- Do something with results
@

For reproducibility, you can leverage a 'NixContext' that's already been introduced to introduce binaries, either by specifying a Nixpkgs package name or by writing out a full derivation.

-}

module Test.Sandwich.Contexts.Files (
  -- * Introduce a file directly
  introduceFile
  , introduceFile'

  -- * Introduce a binary from the environment
  , introduceBinaryViaEnvironment
  , introduceBinaryViaEnvironment'

  -- * Introduce a binary from a Nix package
  , introduceBinaryViaNixPackage
  , introduceBinaryViaNixPackage'
  , getBinaryViaNixPackage
  , getBinaryViaNixPackage'

  -- * Introduce file from a Nix package
  , introduceFileViaNixPackage
  , introduceFileViaNixPackage'
  , introduceFileViaNixPackage''
  , getFileViaNixPackage

  -- * Introduce a binary from a Nix derivation
  , introduceBinaryViaNixDerivation
  , introduceBinaryViaNixDerivation'
  , getBinaryViaNixDerivation
  , getBinaryViaNixDerivation'

  -- * Introduce a file from a Nix derivation
  , introduceFileViaNixDerivation
  , introduceFileViaNixDerivation'
  , introduceFileViaNixDerivation''
  , getFileViaNixDerivation

  -- * Get a file
  , askFile
  , askFile'

  -- * Helpers for file-finding callbacks
  , defaultFindFile
  , findFirstFile
  , findFirstFileInDirs

  -- * Low-level
  , mkFileLabel
  , defaultFileContextVisibilityThreshold

  -- * Types
  , EnvironmentFile(..)
  , HasFile
  , FileValue
  ) where

import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Trans.Except
import Data.String.Interpolate
import GHC.TypeLits
import Relude
import System.FilePath
import System.Info (os)
import Test.Sandwich
import Test.Sandwich.Contexts.Files.Types
import Test.Sandwich.Contexts.Nix
import UnliftIO.Directory


-- | Introduce a file by providing its path.
introduceFile :: forall a context m. (
  MonadUnliftIO m, KnownSymbol a
  )
  -- | Path to the file
  => FilePath
  -- | Child spec
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -- | Parent spec
  -> SpecFree context m ()
introduceFile path = introduceFile' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold }) path

-- | Same as 'introduceFile', but allows passing custom 'NodeOptions'.
introduceFile' :: forall a context m. (
  MonadUnliftIO m, KnownSymbol a
  )
  => NodeOptions
  -> FilePath
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceFile' nodeOptions path = introduce' nodeOptions [i|#{binaryName} (binary from PATH)|] (mkFileLabel @a) (return $ EnvironmentFile path) (const $ return ())
  where
    -- Saw a bug where we couldn't embed "symbolVal proxy" directly in the quasi-quote above.
    -- Failed with "Couldn't match kind ‘Bool’ with ‘Symbol’"
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

-- | Introduce a file from the PATH, which must be present when tests are run.
-- Useful when you want to set up your own environment with binaries etc. to use in tests.
-- Throws an exception if the desired file is not available.
introduceBinaryViaEnvironment :: forall a context m. (
  MonadUnliftIO m, KnownSymbol a
  )
  -- | Parent spec
  => SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -- | Child spec
  -> SpecFree context m ()
introduceBinaryViaEnvironment = introduceBinaryViaEnvironment' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })

-- | Same as 'introduceBinaryViaEnvironment', but allows you to pass custom 'NodeOptions'.
introduceBinaryViaEnvironment' :: forall a context m. (
  MonadUnliftIO m, KnownSymbol a
  )
  => NodeOptions
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceBinaryViaEnvironment' nodeOptions = introduce' nodeOptions [i|#{binaryName} (binary from PATH)|] (mkFileLabel @a) alloc cleanup
  where
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

    alloc = do
      liftIO (findExecutable binaryName) >>= \case
        Nothing -> expectationFailure [i|Couldn't find binary '#{binaryName}' on PATH|]
        Just path -> return $ EnvironmentFile path

    cleanup _ = return ()

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.
  -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'.
  => NixPackageName
  -- | Callback to find the desired file within the Nix derivation path.
  -- It will be passed the derivation path, and should return the file. For example,
  -- tryFindFile "\/nix\/store\/...selenium-server-standalone-3.141.59" may return
  -- "\/nix\/store\/...selenium-server-standalone-3.141.59\/share\/lib\/selenium-server-standalone-3.141.59\/selenium-server-standalone-3.141.59.jar".
  -> (FilePath -> IO FilePath)
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceFileViaNixPackage' = introduceFileViaNixPackage'' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })

-- | Same as 'introduceFileViaNixPackage'', but allows passing custom 'NodeOptions'.
introduceFileViaNixPackage'' :: forall a context m. (
  HasBaseContext context, HasNixContext context
  , MonadUnliftIO m, KnownSymbol a
  )
  -- | Nix package name which contains the desired file.
  => NodeOptions
  -> NixPackageName
  -- | Callback to find the desired file within the Nix derivation path.
  -- It will be passed the derivation path, and should return the file. For example,
  -- tryFindFile "\/nix\/store\/...selenium-server-standalone-3.141.59" may return
  -- "\/nix\/store\/...selenium-server-standalone-3.141.59\/share\/lib\/selenium-server-standalone-3.141.59\/selenium-server-standalone-3.141.59.jar".
  -> (FilePath -> IO FilePath)
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceFileViaNixPackage'' nodeOptions packageName tryFindFile = introduce' nodeOptions [i|#{binaryName} (file via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ())
  where
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

    alloc = buildNixPackage packageName >>= \p -> EnvironmentFile <$> liftIO (tryFindFile p)

-- | Lower-level version of 'introduceFileViaNixPackage'.
getFileViaNixPackage :: forall context m. (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadLoggerIO m
  )
  -- | Nix package name which contains the desired file.
  => NixPackageName
  -- | Callback to find the desired file, as in 'introduceFileViaNixPackage'.
  -> (FilePath -> IO FilePath)
  -> m FilePath
getFileViaNixPackage packageName tryFindFile = buildNixPackage packageName >>= liftIO . tryFindFile

-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.
-- It's recommended to use this with -XTypeApplications.
--
-- This will search for an executable file with the given name in the "bin" directory of the Nix output.
-- On MacOS, it will also recursively search the "Applications" directory. This makes it seamless when you
-- want to work with a derivation like "firefox", which is bundled as an application on macOS.
introduceBinaryViaNixPackage :: forall a context m. (
  HasBaseContext context, HasNixContext context
  , MonadUnliftIO m, KnownSymbol a
  )
  -- | Nix package name which contains the desired binary.
  -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'.
  -- For example, you can use the "hello" binary from the "hello" package like this:
  --
  -- introduceBinaryViaNixPackage' @"hello" "hello"
  => NixPackageName
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceBinaryViaNixPackage = introduceBinaryViaNixPackage' @a (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })

-- | Same as 'introduceBinaryViaNixPackage', but allows passing custom 'NodeOptions'.
introduceBinaryViaNixPackage' :: forall a context m. (
  HasBaseContext context, HasNixContext context
  , MonadUnliftIO m, KnownSymbol a
  )
  -- | Nix package name which contains the desired binary.
  => NodeOptions
  -> NixPackageName
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceBinaryViaNixPackage' nodeOptions packageName = introduce' nodeOptions [i|#{binaryName} (binary via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ())
  where
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

    alloc = buildNixPackage packageName >>= tryFindBinary binaryName

-- | Lower-level version of 'introduceBinaryViaNixPackage'.
getBinaryViaNixPackage :: forall a context m. (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadLoggerIO m, KnownSymbol a
  )
  -- | Nix package name which contains the desired binary.
  => NixPackageName
  -> m FilePath
getBinaryViaNixPackage packageName = do
  unEnvironmentFile <$> (buildNixPackage packageName >>= tryFindBinary (symbolVal (Proxy @a)))

-- | Lower-level version of 'introduceBinaryViaNixPackage'.
getBinaryViaNixPackage' :: forall a context m. (
  HasBaseContext context, MonadReader context m
  , MonadLogger m, MonadUnliftIO m, KnownSymbol a
  )
  -- | 'NixContext' to use.
  => NixContext
  -- | Nix package name which contains the desired binary.
  -> NixPackageName
  -> m FilePath
getBinaryViaNixPackage' nc packageName = do
  unEnvironmentFile <$> (buildNixPackage' nc packageName >>= tryFindBinary (symbolVal (Proxy @a)))

-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.
-- It's recommended to use this with -XTypeApplications.
introduceBinaryViaNixDerivation :: 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 ()
introduceBinaryViaNixDerivation = introduceBinaryViaNixDerivation' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })

-- | Same as 'introduceBinaryViaNixDerivation', but allows passing custom 'NodeOptions'.
introduceBinaryViaNixDerivation' :: forall a context m. (
  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
  )
  -- | Nix derivation as a string.
  => NodeOptions
  -> Text
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceBinaryViaNixDerivation' nodeOptions derivation = introduce' nodeOptions [i|#{binaryName} (binary via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ())
  where
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

    alloc = buildNixCallPackageDerivation derivation >>= tryFindBinary binaryName

-- | Lower-level version of 'introduceBinaryViaNixDerivation'.
getBinaryViaNixDerivation :: forall a context m. (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadLoggerIO m, KnownSymbol a
  )
  -- | Nix derivation as a string.
  => Text
  -> m FilePath
getBinaryViaNixDerivation derivation =
  unEnvironmentFile <$> (buildNixCallPackageDerivation derivation >>= tryFindBinary (symbolVal (Proxy @a)))

-- | Lower-level version of 'getBinaryViaNixDerivation'.
getBinaryViaNixDerivation' :: forall a context m. (
  HasBaseContextMonad context m
  , MonadUnliftIO m, MonadLoggerIO m, KnownSymbol a
  )
  -- | Nix context.
  => NixContext
  -- | Nix derivation as a string.
  -> Text
  -> m FilePath
getBinaryViaNixDerivation' nc derivation =
  unEnvironmentFile <$> (buildNixCallPackageDerivation' nc derivation >>= tryFindBinary (symbolVal (Proxy @a)))

-- | 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.
  => Text
  -- | Callback to find the desired file.
  -> (FilePath -> IO FilePath)
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceFileViaNixDerivation' = introduceFileViaNixDerivation'' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })

-- | Same as 'introduceFileViaNixDerivation'', but allows passing custom 'NodeOptions'.
introduceFileViaNixDerivation'' :: forall a context m. (
  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
  )
  -- | Nix derivation as a string.
  => NodeOptions
  -> Text
  -- | Callback to find the desired file.
  -> (FilePath -> IO FilePath)
  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
  -> SpecFree context m ()
introduceFileViaNixDerivation'' nodeOptions derivation tryFindFile = introduce' nodeOptions [i|#{binaryName} (file via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ())
  where
    binaryName :: String
    binaryName = symbolVal (Proxy @a)

    alloc = EnvironmentFile <$> (buildNixCallPackageDerivation derivation >>= liftIO . tryFindFile)

-- | Lower-level version of 'introduceFileViaNixDerivation'.
getFileViaNixDerivation :: forall context m. (
  HasBaseContextMonad context m, HasNixContext context
  , MonadUnliftIO m, MonadLoggerIO m
  )
  -- | Nix derivation as a string.
  => Text
  -- | Callback to find the desired file.
  -> (FilePath -> IO FilePath)
  -> m FilePath
getFileViaNixDerivation derivation tryFindFile = buildNixCallPackageDerivation derivation >>= liftIO . tryFindFile


-- | Default binary search function used in 'getBinaryViaNixPackage' etc.
tryFindBinary :: (MonadIO m) => String -> FilePath -> m (EnvironmentFile a)
tryFindBinary binaryName env = case os of
  "darwin" -> do
    dirsToSearch <- filterM doesDirectoryExist [env </> "bin", env </> "Applications"]
    let predicate x = andM [(isExecutable x), (return (takeFileName x == binaryName))]
    -- We use own own implementation here because we want to recursively search under "Applications"
    EnvironmentFile <$> liftIO (findFirstFileInDirs predicate dirsToSearch)
    where
      isExecutable :: FilePath -> IO Bool
      isExecutable path = executable <$> getPermissions path
  _ -> do
    -- This is the implementation from System.Directory, which is *not* recursive and is more performant
    -- than 'findFirstFile' because it doesn't list directories.
    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 = findFirstFile (\x -> return (takeFileName x == name))

-- | 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 = findFirstFileInDirs predicate [dir]

-- | 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.
findFirstFileInDirs :: (FilePath -> IO Bool) -> [FilePath] -> IO FilePath
findFirstFileInDirs predicate dirs = runExceptT (sequence_ (fmap go dirs)) >>= \case
  Left x -> return x
  Right () -> expectationFailure [i|Couldn't find file matching predicate in '#{dirs}'|]
  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)