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 #1019

Fixes #1017

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)

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 ()

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

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

src/Stack/Solver.hs

@@ -28,14 +28,14 @@ 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
 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

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,15 +29,14 @@ 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
 
 upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
         => 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

src/System/Process/PagerEditor.hs

@@ -22,14 +22,14 @@ 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(..))
 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'

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
 

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

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