Skip to content

Commit cf6d1cf

Browse files
robstewart57robstewart57
committed
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#1019 Fixes commercialhaskell#1017
1 parent c759ccf commit cf6d1cf

10 files changed

Lines changed: 39 additions & 25 deletions

File tree

‎src/Path/IO.hs‎

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,9 @@ module Path.IO
3333
,createTree
3434
,dropRoot
3535
,parseCollapsedAbsFile
36-
,parseCollapsedAbsDir)
36+
,parseCollapsedAbsDir
37+
,withCanonicalizedSystemTempDirectory
38+
,withCanonicalizedTempDirectory)
3739
where
3840

3941
import Control.Exception hiding (catch)
@@ -48,6 +50,7 @@ import Path.Internal (Path(..))
4850
import qualified System.Directory as D
4951
import qualified System.FilePath as FP
5052
import System.IO.Error
53+
import System.IO.Temp
5154

5255
data ResolveException
5356
= ResolveDirFailed (Path Abs Dir) FilePath FilePath
@@ -289,3 +292,18 @@ dropRoot (Path l) = Path (FP.dropDrive l)
289292
ignoreDoesNotExist :: MonadIO m => IO () -> m ()
290293
ignoreDoesNotExist f =
291294
liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)
295+
296+
withCanonicalizedSystemTempDirectory :: (MonadMask m, MonadIO m)
297+
=> String -- ^ Directory name template.
298+
-> (FilePath -> m a) -- ^ Callback that can use the canonicalized directory
299+
-> m a
300+
withCanonicalizedSystemTempDirectory template action =
301+
withSystemTempDirectory template (\path -> liftIO (D.canonicalizePath path) >>= action)
302+
303+
withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m)
304+
=> FilePath -- ^ Temp directory to create the directory in
305+
-> String -- ^ Directory name template.
306+
-> (FilePath -> m a) -- ^ Callback that can use the canonicalized directory
307+
-> m a
308+
withCanonicalizedTempDirectory targetDir template action =
309+
withTempDirectory targetDir template (\path -> liftIO (D.canonicalizePath path) >>= action)

‎src/Stack/Build/Execute.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -81,8 +81,6 @@ import System.Environment (getExecutablePath)
8181
import System.Exit (ExitCode (ExitSuccess))
8282
import qualified System.FilePath as FP
8383
import System.IO
84-
import System.IO.Temp (withSystemTempDirectory)
85-
8684
import System.PosixCompat.Files (createLink)
8785
import System.Process.Read
8886
import System.Process.Run
@@ -285,7 +283,7 @@ withExecuteEnv :: M env m
285283
-> (ExecuteEnv -> m a)
286284
-> m a
287285
withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap inner = do
288-
withSystemTempDirectory stackProgName $ \tmpdir -> do
286+
withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do
289287
tmpdir' <- parseAbsDir tmpdir
290288
configLock <- newMVar ()
291289
installLock <- newMVar ()

‎src/Stack/SDist.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ import Distribution.Version (simplifyVersionRange, orLaterVersion, ear
3939
import Distribution.Version.Extra
4040
import Network.HTTP.Client.Conduit (HasHttpManager)
4141
import Path
42+
import Path.IO
4243
import Prelude -- Fix redundant import warnings
4344
import Stack.Build (mkBaseConfigOpts)
4445
import Stack.Build.Execute
@@ -50,7 +51,6 @@ import Stack.Package
5051
import Stack.Types
5152
import Stack.Types.Internal
5253
import qualified System.FilePath as FP
53-
import System.IO.Temp (withSystemTempDirectory)
5454

5555
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
5656

@@ -188,7 +188,7 @@ readLocalPackage pkgDir = do
188188
-- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.
189189
getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File)
190190
getSDistFileList lp =
191-
withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do
191+
withCanonicalizedSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do
192192
menv <- getMinimalEnvOverride
193193
let bopts = defaultBuildOpts
194194
baseConfigOpts <- mkBaseConfigOpts bopts

‎src/Stack/Setup.hs‎

Lines changed: 4 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -78,8 +78,6 @@ import System.Environment (getExecutablePath)
7878
import System.Exit (ExitCode (ExitSuccess))
7979
import System.FilePath (searchPathSeparator)
8080
import qualified System.FilePath as FP
81-
import System.IO.Temp (withSystemTempDirectory)
82-
import System.IO.Temp (withTempDirectory)
8381
import System.Process (rawSystem)
8482
import System.Process.Read
8583
import System.Process.Run (runIn)
@@ -451,7 +449,7 @@ upgradeCabal menv wc = do
451449
, T.pack $ versionString newest
452450
, ". I'm not upgrading Cabal."
453451
]
454-
else withSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
452+
else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
455453
$logInfo $ T.concat
456454
[ "Installing Cabal-"
457455
, T.pack $ versionString newest
@@ -844,7 +842,7 @@ installGHCPosix version _ archiveFile archiveType destDir = do
844842
$logDebug $ "make: " <> T.pack makeTool
845843
$logDebug $ "tar: " <> T.pack tarTool
846844

847-
withSystemTempDirectory "stack-setup" $ \root' -> do
845+
withCanonicalizedSystemTempDirectory "stack-setup" $ \root' -> do
848846
root <- parseAbsDir root'
849847
dir <-
850848
liftM (root Path.</>) $
@@ -1049,7 +1047,7 @@ installGHCWindows version si archiveFile archiveType destDir = do
10491047

10501048
run7z <- setup7z si
10511049

1052-
withTempDirectory (toFilePath $ parent destDir)
1050+
withCanonicalizedTempDirectory (toFilePath $ parent destDir)
10531051
((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do
10541052
tmpDir <- parseAbsDir tmpDir0
10551053
run7z (parent archiveFile) archiveFile
@@ -1277,7 +1275,7 @@ sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m)
12771275
=> EnvOverride
12781276
-> WhichCompiler
12791277
-> m ()
1280-
sanityCheck menv wc = withSystemTempDirectory "stack-sanity-check" $ \dir -> do
1278+
sanityCheck menv wc = withCanonicalizedSystemTempDirectory "stack-sanity-check" $ \dir -> do
12811279
dir' <- parseAbsDir dir
12821280
let fp = toFilePath $ dir' </> $(mkRelFile "Main.hs")
12831281
liftIO $ writeFile fp $ unlines

‎src/Stack/Solver.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,14 +28,14 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
2828
import qualified Data.Yaml as Yaml
2929
import Network.HTTP.Client.Conduit (HasHttpManager)
3030
import Path
31+
import Path.IO (withCanonicalizedSystemTempDirectory)
3132
import Prelude
3233
import Stack.BuildPlan
3334
import Stack.Types
3435
import System.Directory (copyFile,
3536
createDirectoryIfMissing,
3637
getTemporaryDirectory)
3738
import qualified System.FilePath as FP
38-
import System.IO.Temp
3939
import System.Process.Read
4040

4141
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
4444
-> Map PackageName Version -- ^ constraints
4545
-> [String] -- ^ additional arguments
4646
-> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool))
47-
cabalSolver wc cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do
47+
cabalSolver wc cabalfps constraints cabalArgs = withCanonicalizedSystemTempDirectory "cabal-solver" $ \dir -> do
4848
configLines <- getCabalConfig dir constraints
4949
let configFile = dir FP.</> "cabal.config"
5050
liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines

‎src/Stack/Upgrade.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import qualified Data.Text as T
1818
import Development.GitRev (gitHash)
1919
import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager)
2020
import Path
21+
import Path.IO
2122
import qualified Paths_stack as Paths
2223
import Stack.Build
2324
import Stack.Types.Build
@@ -28,15 +29,14 @@ import Stack.Setup
2829
import Stack.Types
2930
import Stack.Types.Internal
3031
import Stack.Types.StackT
31-
import System.IO.Temp (withSystemTempDirectory)
3232
import System.Process (readProcess)
3333
import System.Process.Run
3434

3535
upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
3636
=> Maybe String -- ^ git repository to use
3737
-> Maybe AbstractResolver
3838
-> m ()
39-
upgrade gitRepo mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do
39+
upgrade gitRepo mresolver = withCanonicalizedSystemTempDirectory "stack-upgrade" $ \tmp' -> do
4040
menv <- getMinimalEnvOverride
4141
tmp <- parseAbsDir tmp'
4242
mdir <- case gitRepo of

‎src/System/Process/PagerEditor.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -22,14 +22,14 @@ import Control.Exception (try,IOException,throwIO,Exception)
2222
import Data.ByteString.Lazy (ByteString,hPut,readFile)
2323
import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder)
2424
import Data.Typeable (Typeable)
25+
import Path.IO
2526
import System.Directory (findExecutable)
2627
import System.Environment (lookupEnv)
2728
import System.Exit (ExitCode(..))
2829
import System.FilePath ((</>))
2930
import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe)
3031
,CreateProcess(std_in, close_fds, delegate_ctlc))
3132
import System.IO (hClose,Handle,hPutStr,readFile,withFile,IOMode(WriteMode),stdout)
32-
import System.IO.Temp (withSystemTempDirectory)
3333

3434
-- | Run pager, providing a function that writes to the pager's input.
3535
pageWriter :: (Handle -> IO ()) -> IO ()
@@ -89,7 +89,7 @@ editFile path =
8989
-- | Run editor, providing functions to write and read the file contents.
9090
editReaderWriter :: forall a. String -> (Handle -> IO ()) -> (FilePath -> IO a) -> IO a
9191
editReaderWriter filename writer reader =
92-
withSystemTempDirectory ""
92+
withCanonicalizedSystemTempDirectory ""
9393
(\p -> do let p' = p </> filename
9494
withFile p' WriteMode writer
9595
editFile p'

‎src/test/Network/HTTP/Download/VerifiedSpec.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,14 +9,14 @@ import Data.Maybe
99
import Network.HTTP.Client.Conduit
1010
import Network.HTTP.Download.Verified
1111
import Path
12+
import Path.IO
1213
import System.Directory
13-
import System.IO.Temp
1414
import Test.Hspec hiding (shouldNotBe, shouldNotReturn)
1515

1616

1717
-- TODO: share across test files
1818
withTempDir :: (Path Abs Dir -> IO a) -> IO a
19-
withTempDir f = withSystemTempDirectory "NHD_VerifiedSpec" $ \dirFp -> do
19+
withTempDir f = withCanonicalizedSystemTempDirectory "NHD_VerifiedSpec" $ \dirFp -> do
2020
dir <- parseAbsDir dirFp
2121
f dir
2222

‎src/test/Stack/BuildPlanSpec.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -12,9 +12,9 @@ import Data.Monoid
1212
import qualified Data.Map as Map
1313
import qualified Data.Set as Set
1414
import Network.HTTP.Conduit (Manager)
15+
import Path.IO
1516
import Prelude -- Fix redundant import warnings
1617
import System.Directory
17-
import System.IO.Temp
1818
import System.Environment
1919
import Test.Hspec
2020
import Stack.Config
@@ -44,7 +44,7 @@ spec = beforeAll setup $ afterAll teardown $ do
4444
let loadBuildConfigRest m = runStackLoggingT m logLevel False False
4545
let inTempDir action = do
4646
currentDirectory <- getCurrentDirectory
47-
withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do
47+
withCanonicalizedSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do
4848
let enterDir = setCurrentDirectory tempDir
4949
let exitDir = setCurrentDirectory currentDirectory
5050
bracket_ enterDir exitDir action

‎src/test/Stack/ConfigSpec.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -10,10 +10,10 @@ import Data.Maybe
1010
import Data.Monoid
1111
import Network.HTTP.Conduit (Manager)
1212
import Path
13+
import Path.IO
1314
--import System.FilePath
1415
import Prelude -- Fix redundant import warnings
1516
import System.Directory
16-
import System.IO.Temp
1717
import System.Environment
1818
import Test.Hspec
1919

@@ -48,7 +48,7 @@ spec = beforeAll setup $ afterAll teardown $ do
4848
-- TODO(danburton): not use inTempDir
4949
let inTempDir action = do
5050
currentDirectory <- getCurrentDirectory
51-
withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do
51+
withCanonicalizedSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do
5252
let enterDir = setCurrentDirectory tempDir
5353
let exitDir = setCurrentDirectory currentDirectory
5454
bracket_ enterDir exitDir action
@@ -85,7 +85,7 @@ spec = beforeAll setup $ afterAll teardown $ do
8585
bcRoot bc `shouldBe` parentDir
8686

8787
it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do
88-
withSystemTempDirectory "config-is-here" $ \dirFilePath -> do
88+
withCanonicalizedSystemTempDirectory "config-is-here" $ \dirFilePath -> do
8989
dir <- parseAbsDir dirFilePath
9090
let stackYamlFp = toFilePath (dir </> stackDotYaml)
9191
writeFile stackYamlFp sampleConfig

0 commit comments

Comments
 (0)