From cf6d1cf722c89035c5f2ad11eca58142cecea18d Mon Sep 17 00:00:00 2001 From: Rob Stewart Date: Fri, 25 Sep 2015 00:10:27 +0100 Subject: [PATCH] Canonicalizes temporary directory paths When the $TMPDIR environment variable is set, the directory paths provided by `withSystemTempDirectory` and `withTempDirectory` from System.IO.Temp provided by the temporary library are not canonicalised. This commit wraps these functions into canonicalized versions. See an earlier PR for discussion commercialhaskell/stack#1019 Fixes commercialhaskell/stack#1017 --- src/Path/IO.hs | 20 ++++++++++++++++++- src/Stack/Build/Execute.hs | 4 +--- src/Stack/SDist.hs | 4 ++-- src/Stack/Setup.hs | 10 ++++------ src/Stack/Solver.hs | 4 ++-- src/Stack/Upgrade.hs | 4 ++-- src/System/Process/PagerEditor.hs | 4 ++-- .../Network/HTTP/Download/VerifiedSpec.hs | 4 ++-- src/test/Stack/BuildPlanSpec.hs | 4 ++-- src/test/Stack/ConfigSpec.hs | 6 +++--- 10 files changed, 39 insertions(+), 25 deletions(-) diff --git a/src/Path/IO.hs b/src/Path/IO.hs index ca1bed9999..6adf1820f0 100644 --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -33,7 +33,9 @@ module Path.IO ,createTree ,dropRoot ,parseCollapsedAbsFile - ,parseCollapsedAbsDir) + ,parseCollapsedAbsDir + ,withCanonicalizedSystemTempDirectory + ,withCanonicalizedTempDirectory) where import Control.Exception hiding (catch) @@ -48,6 +50,7 @@ import Path.Internal (Path(..)) import qualified System.Directory as D import qualified System.FilePath as FP import System.IO.Error +import System.IO.Temp data ResolveException = ResolveDirFailed (Path Abs Dir) FilePath FilePath @@ -289,3 +292,18 @@ dropRoot (Path l) = Path (FP.dropDrive l) ignoreDoesNotExist :: MonadIO m => IO () -> m () ignoreDoesNotExist f = liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e) + +withCanonicalizedSystemTempDirectory :: (MonadMask m, MonadIO m) + => String -- ^ Directory name template. + -> (FilePath -> m a) -- ^ Callback that can use the canonicalized directory + -> m a +withCanonicalizedSystemTempDirectory template action = + withSystemTempDirectory template (\path -> liftIO (D.canonicalizePath path) >>= action) + +withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m) + => FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. + -> (FilePath -> m a) -- ^ Callback that can use the canonicalized directory + -> m a +withCanonicalizedTempDirectory targetDir template action = + withTempDirectory targetDir template (\path -> liftIO (D.canonicalizePath path) >>= action) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 55e43e4410..83b60dba1a 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -81,8 +81,6 @@ import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import qualified System.FilePath as FP import System.IO -import System.IO.Temp (withSystemTempDirectory) - import System.PosixCompat.Files (createLink) import System.Process.Read import System.Process.Run @@ -285,7 +283,7 @@ withExecuteEnv :: M env m -> (ExecuteEnv -> m a) -> m a withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap inner = do - withSystemTempDirectory stackProgName $ \tmpdir -> do + withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do tmpdir' <- parseAbsDir tmpdir configLock <- newMVar () installLock <- newMVar () diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 4454502583..ead3980bca 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -39,6 +39,7 @@ import Distribution.Version (simplifyVersionRange, orLaterVersion, ear import Distribution.Version.Extra import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Path.IO import Prelude -- Fix redundant import warnings import Stack.Build (mkBaseConfigOpts) import Stack.Build.Execute @@ -50,7 +51,6 @@ import Stack.Package import Stack.Types import Stack.Types.Internal import qualified System.FilePath as FP -import System.IO.Temp (withSystemTempDirectory) type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) @@ -188,7 +188,7 @@ readLocalPackage pkgDir = do -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File) getSDistFileList lp = - withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do + withCanonicalizedSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do menv <- getMinimalEnvOverride let bopts = defaultBuildOpts baseConfigOpts <- mkBaseConfigOpts bopts diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 551efbebbc..ae46b3b622 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -78,8 +78,6 @@ import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP -import System.IO.Temp (withSystemTempDirectory) -import System.IO.Temp (withTempDirectory) import System.Process (rawSystem) import System.Process.Read import System.Process.Run (runIn) @@ -451,7 +449,7 @@ upgradeCabal menv wc = do , T.pack $ versionString newest , ". I'm not upgrading Cabal." ] - else withSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do + else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do $logInfo $ T.concat [ "Installing Cabal-" , T.pack $ versionString newest @@ -844,7 +842,7 @@ installGHCPosix version _ archiveFile archiveType destDir = do $logDebug $ "make: " <> T.pack makeTool $logDebug $ "tar: " <> T.pack tarTool - withSystemTempDirectory "stack-setup" $ \root' -> do + withCanonicalizedSystemTempDirectory "stack-setup" $ \root' -> do root <- parseAbsDir root' dir <- liftM (root Path.) $ @@ -1049,7 +1047,7 @@ installGHCWindows version si archiveFile archiveType destDir = do run7z <- setup7z si - withTempDirectory (toFilePath $ parent destDir) + withCanonicalizedTempDirectory (toFilePath $ parent destDir) ((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do tmpDir <- parseAbsDir tmpDir0 run7z (parent archiveFile) archiveFile @@ -1277,7 +1275,7 @@ sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> m () -sanityCheck menv wc = withSystemTempDirectory "stack-sanity-check" $ \dir -> do +sanityCheck menv wc = withCanonicalizedSystemTempDirectory "stack-sanity-check" $ \dir -> do dir' <- parseAbsDir dir let fp = toFilePath $ dir' $(mkRelFile "Main.hs") liftIO $ writeFile fp $ unlines diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index dd86ddf2ac..7e8456a88d 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -28,6 +28,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Path.IO (withCanonicalizedSystemTempDirectory) import Prelude import Stack.BuildPlan import Stack.Types @@ -35,7 +36,6 @@ import System.Directory (copyFile, createDirectoryIfMissing, getTemporaryDirectory) import qualified System.FilePath as FP -import System.IO.Temp import System.Process.Read cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) @@ -44,7 +44,7 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo -> Map PackageName Version -- ^ constraints -> [String] -- ^ additional arguments -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) -cabalSolver wc cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do +cabalSolver wc cabalfps constraints cabalArgs = withCanonicalizedSystemTempDirectory "cabal-solver" $ \dir -> do configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 23b99d8154..e3c6405422 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -18,6 +18,7 @@ import qualified Data.Text as T import Development.GitRev (gitHash) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager) import Path +import Path.IO import qualified Paths_stack as Paths import Stack.Build import Stack.Types.Build @@ -28,7 +29,6 @@ import Stack.Setup import Stack.Types import Stack.Types.Internal import Stack.Types.StackT -import System.IO.Temp (withSystemTempDirectory) import System.Process (readProcess) import System.Process.Run @@ -36,7 +36,7 @@ upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpMan => Maybe String -- ^ git repository to use -> Maybe AbstractResolver -> m () -upgrade gitRepo mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do +upgrade gitRepo mresolver = withCanonicalizedSystemTempDirectory "stack-upgrade" $ \tmp' -> do menv <- getMinimalEnvOverride tmp <- parseAbsDir tmp' mdir <- case gitRepo of diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs index b302d3c26b..017f099a49 100644 --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -22,6 +22,7 @@ import Control.Exception (try,IOException,throwIO,Exception) import Data.ByteString.Lazy (ByteString,hPut,readFile) import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder) import Data.Typeable (Typeable) +import Path.IO import System.Directory (findExecutable) import System.Environment (lookupEnv) import System.Exit (ExitCode(..)) @@ -29,7 +30,6 @@ import System.FilePath (()) import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe) ,CreateProcess(std_in, close_fds, delegate_ctlc)) import System.IO (hClose,Handle,hPutStr,readFile,withFile,IOMode(WriteMode),stdout) -import System.IO.Temp (withSystemTempDirectory) -- | Run pager, providing a function that writes to the pager's input. pageWriter :: (Handle -> IO ()) -> IO () @@ -89,7 +89,7 @@ editFile path = -- | Run editor, providing functions to write and read the file contents. editReaderWriter :: forall a. String -> (Handle -> IO ()) -> (FilePath -> IO a) -> IO a editReaderWriter filename writer reader = - withSystemTempDirectory "" + withCanonicalizedSystemTempDirectory "" (\p -> do let p' = p filename withFile p' WriteMode writer editFile p' diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs index c683f8e82b..8984b90740 100644 --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -9,14 +9,14 @@ import Data.Maybe import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path +import Path.IO import System.Directory -import System.IO.Temp import Test.Hspec hiding (shouldNotBe, shouldNotReturn) -- TODO: share across test files withTempDir :: (Path Abs Dir -> IO a) -> IO a -withTempDir f = withSystemTempDirectory "NHD_VerifiedSpec" $ \dirFp -> do +withTempDir f = withCanonicalizedSystemTempDirectory "NHD_VerifiedSpec" $ \dirFp -> do dir <- parseAbsDir dirFp f dir diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs index 1ed0995e58..0ee50fd7c0 100644 --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -12,9 +12,9 @@ import Data.Monoid import qualified Data.Map as Map import qualified Data.Set as Set import Network.HTTP.Conduit (Manager) +import Path.IO import Prelude -- Fix redundant import warnings import System.Directory -import System.IO.Temp import System.Environment import Test.Hspec import Stack.Config @@ -44,7 +44,7 @@ spec = beforeAll setup $ afterAll teardown $ do let loadBuildConfigRest m = runStackLoggingT m logLevel False False let inTempDir action = do currentDirectory <- getCurrentDirectory - withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do + withCanonicalizedSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do let enterDir = setCurrentDirectory tempDir let exitDir = setCurrentDirectory currentDirectory bracket_ enterDir exitDir action diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index ea161a99f9..c6057b9b61 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -10,10 +10,10 @@ import Data.Maybe import Data.Monoid import Network.HTTP.Conduit (Manager) import Path +import Path.IO --import System.FilePath import Prelude -- Fix redundant import warnings import System.Directory -import System.IO.Temp import System.Environment import Test.Hspec @@ -48,7 +48,7 @@ spec = beforeAll setup $ afterAll teardown $ do -- TODO(danburton): not use inTempDir let inTempDir action = do currentDirectory <- getCurrentDirectory - withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do + withCanonicalizedSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do let enterDir = setCurrentDirectory tempDir let exitDir = setCurrentDirectory currentDirectory bracket_ enterDir exitDir action @@ -85,7 +85,7 @@ spec = beforeAll setup $ afterAll teardown $ do bcRoot bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do - withSystemTempDirectory "config-is-here" $ \dirFilePath -> do + withCanonicalizedSystemTempDirectory "config-is-here" $ \dirFilePath -> do dir <- parseAbsDir dirFilePath let stackYamlFp = toFilePath (dir stackDotYaml) writeFile stackYamlFp sampleConfig