TestEnv.hs

module Test.Hls.TestEnv
  ( HlsLogStderr(..)
  , HlsPluginLogStderr(..)
  , HlsHarnessStderr(..)
  , HlsHarnessNoTestdirCleanup(..)
  , HlsTestRootDir(..)
  , LspTimeout(..)
  , hlsTestOptions
  , wrapCliTestOptions
  , getTestRootDir
  ) where

import           Control.Monad      (guard)
import           Data.Data          (Proxy (..))
import           Data.Foldable      (traverse_)
import           Data.Maybe         (catMaybes)
import           System.Directory   (createDirectoryIfMissing,
                                     getTemporaryDirectory, makeAbsolute,
                                     removePathForcibly)
import           System.Environment (lookupEnv, setEnv, unsetEnv)
import           System.FilePath    ((</>))
import           Test.Tasty         (TestTree, askOption, withResource)
import           Test.Tasty.Options (IsOption (defaultValue, optionCLParser, optionHelp, optionName, parseValue),
                                     OptionDescription (..), flagCLParser,
                                     safeRead, safeReadBool)

newtype HlsLogStderr = HlsLogStderr Bool
instance IsOption HlsLogStderr where
  defaultValue = HlsLogStderr False
  parseValue s = HlsLogStderr <$> safeReadBool s
  optionName = pure "log-stderr"
  optionHelp = pure "Log all HLS messages to stderr"
  optionCLParser = flagCLParser Nothing (HlsLogStderr True)

newtype HlsPluginLogStderr = HlsPluginLogStderr Bool
instance IsOption HlsPluginLogStderr where
  defaultValue = HlsPluginLogStderr False
  parseValue s = HlsPluginLogStderr <$> safeReadBool s
  optionName = pure "plugin-log-stderr"
  optionHelp = pure "Log all messages of the hls plugin under test to stderr"
  optionCLParser = flagCLParser Nothing (HlsPluginLogStderr True)

newtype HlsHarnessStderr = HlsHarnessStderr Bool
instance IsOption HlsHarnessStderr where
  defaultValue = HlsHarnessStderr False
  parseValue s = HlsHarnessStderr <$> safeReadBool s
  optionName = pure "test-harness-log-stderr"
  optionHelp = pure "Log test setup messages to stderr"
  optionCLParser = flagCLParser Nothing (HlsHarnessStderr True)

newtype HlsHarnessNoTestdirCleanup = HlsHarnessNoTestdirCleanup Bool
instance IsOption HlsHarnessNoTestdirCleanup where
  defaultValue = HlsHarnessNoTestdirCleanup False
  parseValue s = HlsHarnessNoTestdirCleanup <$> safeReadBool s
  optionName = pure "test-harness-no-testdir-cleanup"
  optionHelp = pure "Don't remove the test directories after test execution"
  optionCLParser = flagCLParser Nothing (HlsHarnessNoTestdirCleanup True)

newtype HlsTestRootDir = HlsTestRootDir (Maybe FilePath)
instance IsOption HlsTestRootDir where
  defaultValue = HlsTestRootDir Nothing
  parseValue s = Just . HlsTestRootDir . Just $ s
  optionName = pure "test-root-dir"
  optionHelp = pure "Root directory for test file isolation"

newtype LspTimeout = LspTimeout (Maybe Int)
instance IsOption LspTimeout where
  defaultValue = LspTimeout Nothing
  parseValue s = LspTimeout . Just <$> safeRead s
  optionName = pure "lsp-timeout"
  optionHelp = pure "Set a specific test timeout in seconds"

hlsTestOptions :: [OptionDescription]
hlsTestOptions =
  [ Option (Proxy @HlsLogStderr)
  , Option (Proxy @HlsPluginLogStderr)
  , Option (Proxy @HlsHarnessStderr)
  , Option (Proxy @HlsHarnessNoTestdirCleanup)
  , Option (Proxy @HlsTestRootDir)
  , Option (Proxy @LspTimeout)
  ]

-- | Use tasty cli options to set legacy environment variables
wrapCliTestOptions :: TestTree -> TestTree
wrapCliTestOptions tree =
    askOption $ \(HlsLogStderr logStderr) ->
    askOption $ \(HlsPluginLogStderr pluginStderr) ->
    askOption $ \(HlsTestRootDir rootDir) ->
    askOption $ \(HlsHarnessStderr harnessStderr) ->
    askOption $ \(HlsHarnessNoTestdirCleanup harnessNoTestdirCleanup) ->
    askOption $ \(LspTimeout timeout) ->
    let overrides = catMaybes
            [ ("HLS_TEST_LOG_STDERR", "1")                 <$ guard logStderr
            , ("HLS_TEST_PLUGIN_LOG_STDERR", "1")          <$ guard pluginStderr
            , ("HLS_TEST_ROOTDIR",)                        <$> rootDir
            , ("HLS_TEST_HARNESS_STDERR", "1")             <$ guard harnessStderr
            , ("HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP", "1") <$ guard harnessNoTestdirCleanup
            , ("LSP_TIMEOUT",) . show                      <$> timeout
            ]
    in withRunEnv overrides tree

-- | Root directory for all test files. Honours 'HLS_TEST_ROOTDIR', else the
-- system temp directory.
getTestRootDir :: IO FilePath
getTestRootDir = do
  mRootDir <- lookupEnv "HLS_TEST_ROOTDIR"
  makeAbsolute =<< case mRootDir of
    Just rootDir -> pure rootDir
    Nothing      -> (</> "hls-test-root") <$> getTemporaryDirectory

-- | Apply the per-run environment around the wrapped tests, then restore it and
-- drop the hie-bios cache.
--
-- NB: Needs to be applied once, before any test thread starts, because mutating
-- the process environment is inherently thread-unsafe.
withRunEnv :: [(String, String)] -> TestTree -> TestTree
withRunEnv overrides tree = withResource acquire release (const tree)
  where
    acquire = do
      saved <- setOverrides overrides
      hieBiosCacheDir <- (</> "hie-bios") <$> getTestRootDir
      createDirectoryIfMissing True hieBiosCacheDir
      -- TODO: Until the following PR is merged, tests cannot run concurrently
      -- using this single directory: https://github.com/haskell/hie-bios/pull/520
      savedHieBios <- setOverrides [("HIE_BIOS_CACHE_DIR", hieBiosCacheDir)]
      pure (saved ++ savedHieBios, hieBiosCacheDir)

    release (saved, hieBiosCacheDir) = do
      restoreEnvs saved
      removePathForcibly hieBiosCacheDir

setOverrides :: [(String, String)] -> IO [(String, Maybe String)]
setOverrides = traverse $ \(k, v) -> do
  old <- lookupEnv k
  setEnv k v
  pure (k, old)

restoreEnvs :: [(String, Maybe String)] -> IO ()
restoreEnvs = traverse_ $ \(k, mv) -> maybe (unsetEnv k) (setEnv k) mv