Fix getDispatchEnv / getDamlEnv re-entrancy. (#951)

* Add two failing getDispatchEnv tests. * Fix getDispatchEnv idempotency. * Fix new test formatting. * Make getDamlAssistantPath look in env first. * Fix daml env var overriding. * Test all the Nothing cases of env var dispatching. * Fix dispatchEnv and getDamlEnv for Nothings. * Add hlint rule to avoid future setEnv debacles. * Fix other uses of setEnv. * Fix type error. * Fix reviewer comments * setEnv comment
2024-09-17 15:57:21 +03:00 · 2019-05-06 21:25:30 +02:00 · 2019-05-06 21:25:30 +02:00 · 2d2159cd0a
commit 2d2159cd0a
parent 0489c6e0a5
11 changed files with 171 additions and 41 deletions
--- a/.hlint.yaml
+++ b/.hlint.yaml
@ -45,6 +45,7 @@
 - warn: {lhs: Data.Text.writeFile, rhs: Data.Text.Extended.writeFileUtf8}
 - warn: {lhs: Data.Text.Lazy.readFile, rhs: Data.Text.Extended.readFileUtf8}
 - warn: {lhs: Data.Text.Lazy.writeFile, rhs: Data.Text.Extended.writeFileUtf8}
+- warn: {lhs: System.Environment.setEnv, rhs: System.Environment.Blank.setEnv}

 # Specify additional command line arguments
 #
--- a/daml-assistant/BUILD.bazel
+++ b/daml-assistant/BUILD.bazel
@ -48,7 +48,6 @@ da_haskell_library(
        "http-client-tls",
        "http-conduit",
        "lens",
-        "main-tester",
        "optparse-applicative",
        "process",
        "safe",
@ -109,7 +108,6 @@ da_haskell_test(
        "directory",
        "extra",
        "filepath",
-        "main-tester",
        "safe-exceptions",
        "tar-conduit",
        "tasty",
--- a/daml-assistant/daml-project-config/DAML/Project/Consts.hs
+++ b/daml-assistant/daml-project-config/DAML/Project/Consts.hs
@ -87,7 +87,15 @@ sdkConfigName = "sdk-config.yaml"

 -- | List of all environment variables handled by daml assistant.
 damlEnvVars :: [String]
-damlEnvVars = [damlPathEnvVar, projectPathEnvVar, sdkPathEnvVar, sdkVersionEnvVar, damlAssistantEnvVar]
+damlEnvVars =
+    [ damlPathEnvVar
+    , projectPathEnvVar
+    , sdkPathEnvVar
+    , sdkVersionEnvVar
+    , sdkVersionLatestEnvVar
+    , damlAssistantEnvVar
+    , damlAssistantVersionEnvVar
+    ]

 -- | Returns the path to the daml assistant data directory.
 --
--- a/daml-assistant/integration-tests/src/Main.hs
+++ b/daml-assistant/integration-tests/src/Main.hs
@ -13,7 +13,7 @@ import Network.HTTP.Client
 import Network.HTTP.Types
 import Network.Socket
 import System.Directory.Extra
-import System.Environment
+import System.Environment.Blank
 import System.FilePath
 import System.IO.Extra
 import System.Process
@ -29,14 +29,14 @@ main =
    withTempDir $ \tmpDir -> do
    -- We manipulate global state via the working directory and
    -- the environment so running tests in parallel will cause trouble.
-    setEnv "TASTY_NUM_THREADS" "1"
+    setEnv "TASTY_NUM_THREADS" "1" True
    oldPath <- getEnv "PATH"
    javaPath <- locateRunfiles "local_jdk/bin"
    mvnPath <- locateRunfiles "mvn_nix/bin"
    let damlDir = tmpDir </> "daml"
    withEnv
        [ ("DAML_HOME", Just damlDir)
-        , ("PATH", Just $ (damlDir </> "bin") <> ":" <> javaPath <> ":" <> mvnPath <> ":" <> oldPath)
+        , ("PATH", Just $ (damlDir </> "bin") <> ":" <> javaPath <> ":" <> mvnPath <> maybe "" (":" <>) oldPath)
        ] $ defaultMain (tests tmpDir)

 tests :: FilePath -> TestTree
--- a/daml-assistant/src/DAML/Assistant/Env.hs
+++ b/daml-assistant/src/DAML/Assistant/Env.hs
@ -27,7 +27,7 @@ import DAML.Project.Config
 import DAML.Project.Consts hiding (getDamlPath, getProjectPath)
 import System.Directory
 import System.FilePath
-import System.Environment
+import System.Environment.Blank
 import System.IO
 import Control.Monad.Extra
 import Control.Exception.Safe
@ -59,11 +59,48 @@ getDamlEnv = do
    envLatestStableSdkVersion <- getLatestStableSdkVersion envDamlPath
    pure Env {..}

+-- | (internal) Override function with environment variable
+-- if it is available.
+overrideWithEnvVar
+    :: String                   -- ^ env var name
+    -> (String -> t)            -- ^ parser for env var
+    -> IO t                     -- ^ calculation to override
+    -> IO t
+overrideWithEnvVar envVar parse calculate =
+    maybeM calculate (pure . parse) (getEnv envVar)
+
+-- | (internal) Same as overrideWithEnvVar but accepts "" as
+-- Nothing and throws exception on parse failure.
+overrideWithEnvVarMaybe
+    :: Exception e
+    => String                   -- ^ env var name
+    -> (String -> Either e t)   -- ^ parser for env var
+    -> IO (Maybe t)             -- ^ calculation to override
+    -> IO (Maybe t)
+overrideWithEnvVarMaybe envVar parse calculate = do
+    valueM <- getEnv envVar
+    case valueM of
+        Nothing -> calculate
+        Just "" -> pure Nothing
+        Just value ->
+            Just <$> requiredE
+                ("Invalid value for environment variable " <> pack envVar <> ".")
+                (parse value)
+
+
+
+-- | Get the latest stable SDK version. Can be overriden with
+-- DAML_SDK_LATEST_VERSION environment variable.
+getLatestStableSdkVersion :: DamlPath -> IO (Maybe SdkVersion)
+getLatestStableSdkVersion damlPath =
+    overrideWithEnvVarMaybe sdkVersionLatestEnvVar (parseVersion . pack) $
+        getLatestStableSdkVersionDefault damlPath
+
 -- | Get the latest stable SDK version. Designed to return Nothing if
 -- anything fails (e.g. machine is offline). The result is cached in
 -- $DAML_HOME/cache/latest-sdk-version.txt and only polled once a day.
-getLatestStableSdkVersion :: DamlPath -> IO (Maybe SdkVersion)
-getLatestStableSdkVersion damlPath =
+getLatestStableSdkVersionDefault :: DamlPath -> IO (Maybe SdkVersion)
+getLatestStableSdkVersionDefault damlPath =
    cacheLatestSdkVersion damlPath $ do
        versionE :: Either AssistantError SdkVersion
            <- try getLatestVersion
@ -90,18 +127,33 @@ testDamlEnv Env{..} = firstJustM (\(test, msg) -> unlessMaybeM test (pure msg))
      , "The project directory does not exist. Please check if DAML_PROJECT is incorrectly set.")
    ]

+-- | Determine the absolute path to the assistant. Can be overriden with
+-- DAML_ASSISTANT env var.
+getDamlAssistantPath :: DamlPath -> IO DamlAssistantPath
+getDamlAssistantPath damlPath =
+    overrideWithEnvVar damlAssistantEnvVar DamlAssistantPath $
+        getDamlAssistantPathDefault damlPath
+
 -- | Determine the absolute path to the assistant.
-getDamlAssistantPath :: Applicative f => DamlPath -> f DamlAssistantPath
-getDamlAssistantPath (DamlPath damlPath)
+getDamlAssistantPathDefault :: Applicative f => DamlPath -> f DamlAssistantPath
+getDamlAssistantPathDefault (DamlPath damlPath)
    -- Our packaging logic for Haskell results in getExecutablePath
    -- pointing to the dynamic linker and getProgramName returning "daml" in
    -- both cases so we use this hack to figure out the executable name.
    | takeFileName damlPath == ".daml-head" = pure $ DamlAssistantPath $ damlPath </> "bin" </> "daml-head"
    | otherwise = pure $ DamlAssistantPath $ damlPath </> "bin" </> "daml"

-- | Determine SDK version of running daml assistant.
+-- | Determine SDK version of running daml assistant. Can be overriden
+-- with DAML_ASSISTANT_VERSION env var.
 getDamlAssistantSdkVersion :: IO (Maybe DamlAssistantSdkVersion)
-getDamlAssistantSdkVersion = fmap DamlAssistantSdkVersion <$> do
+getDamlAssistantSdkVersion =
+    overrideWithEnvVarMaybe damlAssistantVersionEnvVar
+        (fmap DamlAssistantSdkVersion . parseVersion . pack)
+        getDamlAssistantSdkVersionDefault
+
+-- | Determine SDK version of running daml assistant.
+getDamlAssistantSdkVersionDefault :: IO (Maybe DamlAssistantSdkVersion)
+getDamlAssistantSdkVersionDefault = fmap DamlAssistantSdkVersion <$> do
    exePath <- getExecutablePath
    sdkPathM <- fmap SdkPath <$> findM hasSdkConfig (ascendants exePath)
    case sdkPathM of
@ -128,7 +180,7 @@ getDamlAssistantSdkVersion = fmap DamlAssistantSdkVersion <$> do
 getDamlPath :: IO DamlPath
 getDamlPath = wrapErr "Determining daml home directory." $ do
    path <- required "Failed to determine daml path." =<< firstJustM id
-        [ lookupEnv damlPathEnvVar
+        [ getEnv damlPathEnvVar
        , findM hasDamlConfig . ascendants =<< getExecutablePath
        , Just <$> getAppUserDataDirectory "daml"
        ]
@ -147,10 +199,9 @@ getDamlPath = wrapErr "Determining daml home directory." $ do
 -- environment variable.
 getProjectPath :: IO (Maybe ProjectPath)
 getProjectPath = wrapErr "Detecting daml project." $ do
-        pathM <- firstJustM id
-            [ lookupEnv projectPathEnvVar
-            , findM hasProjectConfig . ascendants =<< getCurrentDirectory
-            ]
+        pathM <- overrideWithEnvVarMaybe @SomeException projectPathEnvVar Right $ do
+            cwd <- getCurrentDirectory
+            findM hasProjectConfig (ascendants cwd)
        pure (ProjectPath <$> pathM)

    where
@ -170,12 +221,8 @@ getSdk :: DamlPath
 getSdk damlPath damlAsstSdkVersionM projectPathM =
    wrapErr "Determining SDK version and path." $ do

-        sdkVersion <- firstJustM id
-            [ lookupEnv sdkVersionEnvVar >>= \ vstrM -> pure $ do
-                vstr <- vstrM
-                eitherToMaybe (parseVersion (pack vstr))
-
-            , fromConfig "SDK" (lookupEnv sdkPathEnvVar)
+        sdkVersion <- overrideWithEnvVarMaybe sdkVersionEnvVar (parseVersion . pack) $ firstJustM id
+            [ fromConfig "SDK" (getEnv sdkPathEnvVar)
                               (readSdkConfig . SdkPath)
                               (fmap Just . sdkVersionFromSdkConfig)
            , fromConfig "project" (pure projectPathM)
@ -184,9 +231,8 @@ getSdk damlPath damlAsstSdkVersionM projectPathM =
            , getLatestInstalledSdkVersion damlPath
            ]

-        sdkPath <- firstJustM id
-            [ fmap SdkPath <$> lookupEnv sdkPathEnvVar
-            , useInstalledPath damlPath sdkVersion
+        sdkPath <- overrideWithEnvVarMaybe @SomeException sdkPathEnvVar (Right . SdkPath) $ firstJustM id
+            [ useInstalledPath damlPath sdkVersion
            , autoInstall damlPath damlAsstSdkVersionM sdkVersion
            ]

--- a/daml-assistant/test/DAML/Assistant/Tests.hs
+++ b/daml-assistant/test/DAML/Assistant/Tests.hs
@ -13,7 +13,7 @@ import DAML.Assistant.Types
 import DAML.Assistant.Util
 import DAML.Project.Consts hiding (getDamlPath, getProjectPath)
 import System.Directory
-import System.Environment
+import System.Environment.Blank
 import System.FilePath
 import System.Info.Extra (isWindows)
 import System.IO.Temp
@ -24,7 +24,6 @@ import qualified Test.Tasty.HUnit as Tasty
 import qualified Test.Tasty.QuickCheck as Tasty
 import qualified Data.Text as T
 import Test.Tasty.QuickCheck ((==>))
-import Test.Main (withEnv)
 import System.Info (os)
 import Data.Maybe
 import Control.Exception.Safe
@ -36,14 +35,42 @@ import qualified Data.Conduit.Tar as Tar
 -- unix specific
 import System.PosixCompat.Files (createSymbolicLink)

+-- | Replace all environment variables for test action, then restore them.
+-- Avoids System.Environment.setEnv because it treats empty strings as
+-- "delete environment variable", unlike main-tester's withEnv which
+-- consequently conflates (Just "") with Nothing.
+withEnv :: [(String, Maybe String)] -> IO t -> IO t
+withEnv vs m = bracket pushEnv popEnv (const m)
+    where
+        pushEnv :: IO [(String, Maybe String)]
+        pushEnv = do
+            oldEnv <- getEnvironment
+            let ks  = map fst vs
+                vs' = [(key, Nothing)  | (key, _) <- oldEnv, key `notElem` ks] ++ vs
+            replaceEnv vs'
+
+        popEnv :: [(String, Maybe String)] -> IO ()
+        popEnv vs' = void $ replaceEnv vs'
+
+        replaceEnv :: [(String, Maybe String)] -> IO [(String, Maybe String)]
+        replaceEnv vs' = do
+            forM vs' $ \(key, newVal) -> do
+                oldVal <- getEnv key
+                case newVal of
+                    Nothing -> unsetEnv key
+                    Just val -> setEnv key val True
+                pure (key, oldVal)
+
+
 main :: IO ()
 main = do
-    setEnv "TASTY_NUM_THREADS" "1" -- we need this because we use withEnv in our tests
+    setEnv "TASTY_NUM_THREADS" "1" True -- we need this because we use withEnv in our tests
    Tasty.defaultMain $ Tasty.testGroup "DAML.Assistant"
        [ testAscendants
        , testGetDamlPath
        , testGetProjectPath
        , testGetSdk
+        , testGetDispatchEnv
        , testInstall
        ]

@ -262,6 +289,56 @@ testGetSdk = Tasty.testGroup "DAML.Assistant.Env.getSdk"
            pure ()
    ]

+testGetDispatchEnv :: Tasty.TestTree
+testGetDispatchEnv = Tasty.testGroup "DAML.Assistant.Env.getDispatchEnv"
+    [ Tasty.testCase "getDispatchEnv should be idempotent" $ do
+        withSystemTempDirectory "test-getDispatchEnv" $ \base -> do
+            version <- requiredE "expected this to be valid version" $ parseVersion "1.0.1"
+            let denv = Env
+                    { envDamlPath = DamlPath (base </> ".daml")
+                    , envDamlAssistantPath = DamlAssistantPath (base </> ".daml" </> "bin" </> "strange-daml")
+                    , envDamlAssistantSdkVersion = Just $ DamlAssistantSdkVersion version
+                    , envSdkVersion = Just version
+                    , envLatestStableSdkVersion = Just version
+                    , envSdkPath = Just $ SdkPath (base </> "sdk")
+                    , envProjectPath = Just $ ProjectPath (base </> "proj")
+                    }
+            env1 <- withEnv [] (getDispatchEnv denv)
+            env2 <- withEnv (fmap (fmap Just) env1) (getDispatchEnv denv)
+            Tasty.assertEqual "dispatch envs" env1 env2
+
+    , Tasty.testCase "getDispatchEnv should override getDamlEnv" $ do
+        withSystemTempDirectory "test-getDispatchEnv" $ \base -> do
+            version <- requiredE "expected this to be valid version" $ parseVersion "1.0.1"
+            let denv1 = Env
+                    { envDamlPath = DamlPath (base </> ".daml")
+                    , envDamlAssistantPath = DamlAssistantPath (base </> ".daml" </> "bin" </> "strange-daml")
+                    , envDamlAssistantSdkVersion = Just $ DamlAssistantSdkVersion version
+                    , envSdkVersion = Just version
+                    , envLatestStableSdkVersion = Just version
+                    , envSdkPath = Just $ SdkPath (base </> "sdk")
+                    , envProjectPath = Just $ ProjectPath (base </> "proj")
+                    }
+            env <- withEnv [] (getDispatchEnv denv1)
+            denv2 <- withEnv (fmap (fmap Just) env) getDamlEnv
+            Tasty.assertEqual "daml envs" denv1 denv2
+
+    , Tasty.testCase "getDispatchEnv should override getDamlEnv (2)" $ do
+        withSystemTempDirectory "test-getDispatchEnv" $ \base -> do
+            let denv1 = Env
+                    { envDamlPath = DamlPath (base </> ".daml")
+                    , envDamlAssistantPath = DamlAssistantPath (base </> ".daml" </> "bin" </> "strange-daml")
+                    , envDamlAssistantSdkVersion = Nothing
+                    , envSdkVersion = Nothing
+                    , envLatestStableSdkVersion = Nothing
+                    , envSdkPath = Nothing
+                    , envProjectPath = Nothing
+                    }
+            env <- withEnv [] (getDispatchEnv denv1)
+            denv2 <- withEnv (fmap (fmap Just) env) getDamlEnv
+            Tasty.assertEqual "daml envs" denv1 denv2
+    ]
+

 testAscendants :: Tasty.TestTree
 testAscendants = Tasty.testGroup "DAML.Assistant.ascendants"
--- a/daml-foundations/daml-ghc/src/DA/Test/GHC.hs
+++ b/daml-foundations/daml-ghc/src/DA/Test/GHC.hs
@ -45,7 +45,7 @@ import           Development.IDE.Types.Diagnostics
 import           Data.Maybe
 import           Development.Shake hiding (cmd, withResource)
 import           System.Directory.Extra
-import           System.Environment (setEnv)
+import           System.Environment.Blank (setEnv)
 import           System.FilePath
 import           System.Process (readProcess)
 import           System.IO.Extra
@ -83,7 +83,7 @@ mainVersionDefault = mainWithVersion versionDefault
 mainWithVersion :: Version -> IO ()
 mainWithVersion version =
  with (SS.startScenarioService (\_ -> pure ()) Logger.makeNopHandle) $ \scenarioService -> do
-  setEnv "TASTY_NUM_THREADS" "1"
+  setEnv "TASTY_NUM_THREADS" "1" True
  todoRef <- newIORef DList.empty
  let registerTODO (TODO s) = modifyIORef todoRef (`DList.snoc` ("TODO: " ++ s))
  integrationTest <- getIntegrationTests registerTODO scenarioService version
--- a/daml-foundations/daml-ghc/src/DA/Test/ShakeIdeClient.hs
+++ b/daml-foundations/daml-ghc/src/DA/Test/ShakeIdeClient.hs
@ -20,7 +20,7 @@ import Data.Either
 import Control.Monad
 import Control.Monad.Managed (with)
 import System.Directory
-import System.Environment
+import System.Environment.Blank (setEnv)
 import Control.Monad.IO.Class

 import DA.Service.Daml.Compiler.Impl.Scenario as SS
@ -31,7 +31,7 @@ import Development.IDE.State.API.Testing
 main :: IO ()
 main = with (SS.startScenarioService (\_ -> pure ()) Logger.makeNopHandle) $ \scenarioService -> do
  -- The scenario service is a shared resource so running tests in parallel doesn’t work properly.
-  setEnv "TASTY_NUM_THREADS" "1"
+  setEnv "TASTY_NUM_THREADS" "1" True
  -- The startup of the scenario service is fairly expensive so instead of launching a separate
  -- service for each test, we launch a single service that is shared across all tests.
  Tasty.deterministicMain (ideTests (Just scenarioService))
--- a/daml-foundations/daml-tools/da-hs-daml-cli/tests/Cli.hs
+++ b/daml-foundations/daml-tools/da-hs-daml-cli/tests/Cli.hs
@ -7,7 +7,7 @@ module Cli

 import Control.Exception
 import Options.Applicative
-import System.Environment
+import System.Environment.Blank
 import System.Exit
 import Test.Tasty
 import Test.Tasty.HUnit
@ -16,7 +16,7 @@ import DA.Cli.Args

 main :: IO ()
 main = do
-    setEnv "TASTY_NUM_THREADS" "1"
+    setEnv "TASTY_NUM_THREADS" "1" True
    defaultMain tests

 tests :: TestTree
--- a/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs
+++ b/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs
@ -7,7 +7,7 @@ module DamlcTest

 import Control.Exception
 import qualified Data.Text.Extended as T
-import System.Environment
+import System.Environment.Blank
 import System.IO.Extra
 import System.Exit
 import Test.Tasty
@ -18,7 +18,7 @@ import DA.Daml.GHC.Compiler.Options

 main :: IO ()
 main = do
-    setEnv "TASTY_NUM_THREADS" "1"
+    setEnv "TASTY_NUM_THREADS" "1" True
    defaultMain tests

 -- execTest will call mkOptions internally. Since each call to mkOptions
--- a/libs-haskell/da-hs-base/tests/DataLimit.hs
+++ b/libs-haskell/da-hs-base/tests/DataLimit.hs
@ -11,7 +11,7 @@ import Data.Maybe
 import System.Directory
 import qualified Data.Text as T
 import Data.Aeson (encode)
-import System.Environment
+import System.Environment.Blank
 import Data.Functor

 main :: IO ()
@ -47,11 +47,11 @@ cleanUp s = runManaged $ do
 -- | The CI env doesn't have a home directory so set and unset it if it doesn't exist
 withHomeDir :: IO (Maybe String)
 withHomeDir = do
-    home <- lookupEnv "HOME"
+    home <- getEnv "HOME"
    case home of
        Nothing -> fakeHome
        Just "" -> fakeHome
        Just _ -> pure Nothing

 fakeHome :: IO (Maybe String)
-fakeHome = setEnv "HOME" "." $> Just "HOME"
+fakeHome = setEnv "HOME" "." True $> Just "HOME"