diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs index 8e5e123a1d..4533be713d 100644 --- a/src/Data/Binary/VersionTagged.hs +++ b/src/Data/Binary/VersionTagged.hs @@ -29,7 +29,7 @@ import Data.Monoid ((<>)) import Data.Typeable (Typeable) import Control.Exception.Enclosed (tryAnyDeep) import Path -import Path.IO (createTree) +import Path.IO (ensureDir) import qualified Data.Text as T type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) @@ -40,7 +40,7 @@ taggedEncodeFile :: (BinarySchema a, MonadIO m) -> a -> m () taggedEncodeFile fp x = liftIO $ do - createTree (parent fp) + ensureDir (parent fp) BinaryTagged.taggedEncodeFile (toFilePath fp) x -- | Read from the given file. If the read fails, run the given action and diff --git a/src/Path/Find.hs b/src/Path/Find.hs index 7a88e3182b..fc98b83138 100644 --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -14,7 +14,7 @@ import Control.Monad.IO.Class import System.IO.Error (isPermissionError) import Data.List import Path -import Path.IO +import Path.IO hiding (findFiles) -- | Find the location of a file matching the given predicate. findFileUp :: (MonadIO m,MonadThrow m) @@ -41,7 +41,7 @@ findPathUp :: (MonadIO m,MonadThrow m) -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs t)) -- ^ Absolute path. findPathUp pathType dir p upperBound = - do entries <- listDirectory dir + do entries <- listDir dir case find p (pathType entries) of Just path -> return (Just path) Nothing | Just dir == upperBound -> return Nothing @@ -57,7 +57,7 @@ findFiles dir p traversep = do (dirs,files) <- catchJust (\ e -> if isPermissionError e then Just () else Nothing) - (listDirectory dir) + (listDir dir) (\ _ -> return ([], [])) subResults <- forM dirs diff --git a/src/Path/IO.hs b/src/Path/IO.hs deleted file mode 100644 index 745ac1bf03..0000000000 --- a/src/Path/IO.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | IO actions that might be put in a package at some point. - -module Path.IO - (getWorkingDir - ,parseRelAsAbsDir - ,parseRelAsAbsFile - ,listDirectory - ,resolveDir - ,resolveFile - ,resolveDirMaybe - ,resolveFileMaybe - ,ResolveException(..) - ,removeFile - ,removeFileIfExists - ,removeTree - ,removeTreeIfExists - ,renameFile - ,renameFileIfExists - ,renameDir - ,renameDirIfExists - ,moveFile - ,moveFileIfExists - ,moveDir - ,moveDirIfExists - ,fileExists - ,dirExists - ,copyFile - ,copyFileIfExists - ,copyDirectoryRecursive - ,createTree - ,withCanonicalizedSystemTempDirectory - ,withCanonicalizedTempDirectory) - where - -import Control.Exception hiding (catch) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Either -import Data.Maybe.Extra -import Data.Typeable -import 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 - | ResolveFileFailed (Path Abs Dir) FilePath FilePath - deriving Typeable -instance Exception ResolveException - -instance Show ResolveException where - show (ResolveDirFailed _ _ z) = "Could not resolve directory " ++ z - show (ResolveFileFailed _ _ z) = "Could not resolve file " ++ z - --- | Get the current working directory. -getWorkingDir :: (MonadIO m) => m (Path Abs Dir) -getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir) - --- | Parse a directory path. If it's relative, then the absolute version --- is yielded, based off the working directory. --- --- NOTE that this only works if the directory exists, but does not --- ensure that it's a directory. -parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir) -parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp) - --- | Parse a file path. If it's relative, then the absolute version is --- yielded, based off the working directory. --- --- NOTE that this only works if the file exists, but does not ensure --- that it's a file. -parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File) -parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp) - --- | Appends a stringly-typed relative path to an absolute path, and then --- canonicalizes it. -resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir) -resolveDir x y = - do result <- resolveDirMaybe x y - case result of - Nothing -> - throwM $ ResolveDirFailed x y fp - where fp = toFilePath x FP. y - Just fp -> return fp - --- | Appends a stringly-typed relative path to an absolute path, and then --- canonicalizes it. -resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs File) -resolveFile x y = - do result <- resolveFileMaybe x y - case result of - Nothing -> - throwM $ - ResolveFileFailed x y fp - where fp = toFilePath x FP. y - Just fp -> return fp - --- Internal helper to define resolveDirMaybe and resolveFileMaybe in one -resolveCheckParse :: (MonadIO m) - => (FilePath -> IO Bool) -- check if file/dir does exist - -> (FilePath -> m a) -- parse into absolute file/dir - -> Path Abs Dir - -> FilePath - -> m (Maybe a) -resolveCheckParse check parse x y = do - let fp = toFilePath x FP. y - exists <- liftIO $ check fp - if exists - then do - canonic <- liftIO $ D.canonicalizePath fp - liftM Just (parse canonic) - else return Nothing - --- | Appends a stringly-typed relative path to an absolute path, and then --- canonicalizes it. If the path doesn't exist (and therefore cannot --- be canonicalized, 'Nothing' is returned). -resolveDirMaybe :: (MonadIO m,MonadThrow m) - => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir)) -resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir - --- | Appends a stringly-typed relative path to an absolute path, and then --- canonicalizes it. If the path doesn't exist (and therefore cannot --- be canonicalized, 'Nothing' is returned). -resolveFileMaybe :: (MonadIO m,MonadThrow m) - => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File)) -resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile - --- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. -listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) -listDirectory dir = - do entriesFP <- liftIO (D.getDirectoryContents dirFP) - entries <- - forMaybeM (map (dirFP ++) entriesFP) - (\entryFP -> - do isDir <- liftIO (D.doesDirectoryExist entryFP) - if isDir - then case parseAbsDir entryFP of - Nothing -> return Nothing - Just entryDir -> - if dir `isParentOf` entryDir - then return (Just (Left entryDir)) - else return Nothing - else case parseAbsFile entryFP of - Nothing -> return Nothing - Just entryFile -> return (Just (Right entryFile))) - return (lefts entries,rights entries) - where dirFP = toFilePath dir - --- | Remove a file. Bails out if it doesn't exist. -removeFile :: MonadIO m => Path b File -> m () -removeFile = liftIO . D.removeFile . toFilePath - --- | Remove a file. Optimistically assumes it exists. If it doesn't, --- doesn't complain. -removeFileIfExists :: MonadIO m => Path b File -> m () -removeFileIfExists = ignoreDoesNotExist . removeFile - --- | Rename a file. Bails out if it doesn't exist. -renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m () -renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to)) - --- | Rename a file. Optimistically assumes it exists. If it doesn't, --- doesn't complain. -renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m () -renameFileIfExists from to = ignoreDoesNotExist (renameFile from to) - -renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m () -renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to)) - --- | Rename a directory. Optimistically assumes it exists. If it --- doesn't, doesn't complain. -renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m () -renameDirIfExists from to = ignoreDoesNotExist (renameDir from to) - --- | Make a directory tree, creating parents if needed. -createTree :: MonadIO m => Path b Dir -> m () -createTree = liftIO . D.createDirectoryIfMissing True . toFilePath - --- | Move a file. Bails out if it doesn't exist. -moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m () -moveFile from to = renameFile from (to filename from) - --- | Move a file. Optimistically assumes it exists. If it doesn't, --- doesn't complain. -moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m () -moveFileIfExists from to = ignoreDoesNotExist (moveFile from to) - --- | Move a dir. Bails out if it doesn't exist. -moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m () -moveDir from to = renameDir from (to dirname from) - --- | Move a dir. Optimistically assumes it exists. If it doesn't, --- doesn't complain. -moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m () -moveDirIfExists from to = ignoreDoesNotExist (moveDir from to) - --- | Remove a tree. Bails out if it doesn't exist. -removeTree :: MonadIO m => Path b Dir -> m () -removeTree = liftIO . D.removeDirectoryRecursive . toFilePath - --- | Remove tree, don't complain about non-existent directories. -removeTreeIfExists :: MonadIO m => Path b Dir -> m () -removeTreeIfExists = ignoreDoesNotExist . removeTree - --- | Does the file exist? -fileExists :: MonadIO m => Path b File -> m Bool -fileExists = liftIO . D.doesFileExist . toFilePath - --- | Does the directory exist? -dirExists :: MonadIO m => Path b Dir -> m Bool -dirExists = liftIO . D.doesDirectoryExist . toFilePath - --- | Copies a file to another path. Bails out if it doesn't exist. -copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m () -copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to)) - --- | Copies a file to another path. Optimistically assumes it exists. If --- it doesn't, doesn't complain. -copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m () -copyFileIfExists from to = ignoreDoesNotExist (copyFile from to) - --- | Copy a directory recursively. This just uses 'copyFile', so it is not smart about symbolic --- links or other special files. -copyDirectoryRecursive :: (MonadIO m,MonadThrow m) - => Path Abs Dir -- ^ Source directory - -> Path Abs Dir -- ^ Destination directory - -> m () -copyDirectoryRecursive srcDir destDir = - do liftIO (D.createDirectoryIfMissing False (toFilePath destDir)) - (srcSubDirs,srcFiles) <- listDirectory srcDir - forM_ srcFiles - (\srcFile -> - case stripDir srcDir srcFile of - Nothing -> return () - Just relFile -> copyFile srcFile (destDir relFile)) - forM_ srcSubDirs - (\srcSubDir -> - case stripDir srcDir srcSubDir of - Nothing -> return () - Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir relSubDir)) - --- Utility function for a common pattern of ignoring does-not-exist errors. -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. - -> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory - -> m a -withCanonicalizedSystemTempDirectory template action = - withSystemTempDirectory template (parseRelAsAbsDir >=> action) - -withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m) - => FilePath -- ^ Temp directory to create the directory in - -> String -- ^ Directory name template. - -> (Path Abs Dir -> m a) -- ^ Callback that can use the canonicalized directory - -> m a -withCanonicalizedTempDirectory targetDir template action = - withTempDirectory targetDir template (parseRelAsAbsDir >=> action) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 590b7c8777..13f3a6675c 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -26,7 +26,7 @@ module Stack.Build.Cache ) where import Control.Exception.Enclosed (handleIO) -import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader @@ -59,7 +59,7 @@ getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow => InstallLocation -> m [PackageIdentifier] getInstalledExes loc = do dir <- exeInstalledDir loc - (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir + (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDir dir return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files -- | Mark the given executable as installed @@ -67,7 +67,7 @@ markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do dir <- exeInstalledDir loc - createTree dir + ensureDir dir ident' <- parseRelFile $ packageIdentifierString ident let fp = toFilePath $ dir ident' -- TODO consideration for the future: list all of the executables @@ -76,12 +76,12 @@ markExeInstalled loc ident = do liftIO $ writeFile fp "Installed" -- | Mark the given executable as not installed -markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) +markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m) => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do dir <- exeInstalledDir loc ident' <- parseRelFile $ packageIdentifierString ident - removeFileIfExists (dir ident') + ignoringAbsence (removeFile $ dir ident') -- | Stored on disk to know whether the flags have changed or any -- files have changed. @@ -145,7 +145,7 @@ writeCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, Mon writeCabalMod dir = writeCache dir configCabalMod -- | Delete the caches for the project. -deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m, HasEnvConfig env) +deleteCaches :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadCatch m, HasEnvConfig env) => Path Abs Dir -> m () deleteCaches dir = do {- FIXME confirm that this is acceptable to remove @@ -153,7 +153,7 @@ deleteCaches dir = do removeFileIfExists bfp -} cfp <- configCacheFile dir - removeFileIfExists cfp + ignoringAbsence (removeFile cfp) -- | Write to a cache. writeCache :: (BinarySchema a, MonadIO m) @@ -191,7 +191,7 @@ writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) writeFlagCache gid cache = do file <- flagCacheFile gid liftIO $ do - createTree (parent file) + ensureDir (parent file) taggedEncodeFile file cache -- | Mark a test suite as having succeeded @@ -289,7 +289,7 @@ writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, Mon -> m () writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do file <- precompiledCacheFile pkgident copts depIDs - createTree $ parent file + ensureDir (parent file) mlibpath <- case mghcPkgId of Executable _ -> return Nothing diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 6be1e32650..d348b8f02f 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -64,7 +64,7 @@ import Language.Haskell.TH as TH (location) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Extra (toFilePathNoTrailingSep) -import Path.IO +import Path.IO hiding (findExecutable, makeAbsolute) import Prelude hiding (FilePath, writeFile, any) import Stack.Build.Cache import Stack.Build.Haddock @@ -291,7 +291,7 @@ withExecuteEnv :: M env m -> (ExecuteEnv -> m a) -> m a withExecuteEnv menv bopts baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do - withCanonicalizedSystemTempDirectory stackProgName $ \tmpdir -> do + withSystemTempDir stackProgName $ \tmpdir -> do configLock <- newMVar () installLock <- newMVar () idMap <- liftIO $ newTVarIO Map.empty @@ -347,7 +347,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc snapBin <- ( bindirSuffix) `liftM` installationRootDeps localBin <- ( bindirSuffix) `liftM` installationRootLocal destDir <- asks $ configLocalBin . getConfig - createTree destDir + ensureDir destDir destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir @@ -364,7 +364,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc case loc of Snap -> snapBin Local -> localBin - mfp <- resolveFileMaybe bindir $ T.unpack name ++ ext + mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) case mfp of Nothing -> do $logWarn $ T.concat @@ -759,7 +759,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md | console = inner Nothing | otherwise = do logPath <- buildLogPath package msuffix - createTree (parent logPath) + ensureDir (parent logPath) let fp = toFilePath logPath bracket (liftIO $ openBinaryFile fp WriteMode) @@ -882,7 +882,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md distDir <- distDirFromDir pkgDir let setupDir = distDir $(mkRelDir "setup") outputFile = setupDir $(mkRelFile "setup") - createTree setupDir + ensureDir setupDir compilerPath <- case compiler of Ghc -> getGhcPath @@ -1181,7 +1181,7 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do when toRun $ do buildDir <- distDirFromDir pkgDir hpcDir <- hpcDirFromDir pkgDir - when needHpc (createTree hpcDir) + when needHpc (ensureDir hpcDir) let suitesToRun = [ testSuitePair @@ -1204,7 +1204,7 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do _ -> "" tixPath <- liftM (pkgDir ) $ parseRelFile $ exeName ++ ".tix" exePath <- liftM (buildDir ) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName - exists <- fileExists exePath + exists <- doesFileExist exePath menv <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True @@ -1215,10 +1215,10 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do then do -- We clear out the .tix files before doing a run. when needHpc $ do - tixexists <- fileExists tixPath + tixexists <- doesFileExist tixPath when tixexists $ $logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath)) - removeFileIfExists tixPath + ignoringAbsence (removeFile tixPath) let args = toAdditionalArgs topts argsDisplay = case args of @@ -1249,7 +1249,7 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp when isTestTypeLib $ do logPath <- buildLogPath package (Just stestName) - createTree (parent logPath) + ensureDir (parent logPath) liftIO $ hPutStr inH $ show (logPath, testName) liftIO $ hClose inH ec <- liftIO $ waitForProcess ph @@ -1325,7 +1325,7 @@ singleBench runInBase beopts benchesToRun ac ee task installedMap = do cabal False ("bench" : args) -- | Strip Template Haskell "Loading package" lines and making paths absolute. -mungeBuildOutput :: (MonadIO m, MonadThrow m) +mungeBuildOutput :: (MonadIO m, MonadCatch m) => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory @@ -1351,7 +1351,7 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ mabs <- if isValidSuffix y then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ - resolveFileMaybe pkgDir (T.unpack $ T.dropWhile isSpace x) + forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) else return Nothing case mabs of Nothing -> return bs @@ -1373,11 +1373,11 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ getSetupHs :: Path Abs Dir -- ^ project directory -> IO (Path Abs File) getSetupHs dir = do - exists1 <- fileExists fp1 + exists1 <- doesFileExist fp1 if exists1 then return fp1 else do - exists2 <- fileExists fp2 + exists2 <- doesFileExist fp2 if exists2 then return fp2 else throwM $ NoSetupHsFound dir diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 84518b4ef5..28f961745b 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -42,7 +42,6 @@ import Prelude import Stack.Types.Build import Stack.PackageDump import Stack.Types -import System.Directory (getModificationTime) import qualified System.FilePath as FP import System.IO.Error (isDoesNotExistError) import System.Process.Read @@ -152,7 +151,7 @@ generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) + :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) => Text -> EnvOverride -> WhichCompiler @@ -161,10 +160,10 @@ generateHaddockIndex -> Path Abs Dir -> m () generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do - createTree destDir + ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do - let destIndexFile = toFilePath (haddockIndexFile destDir) + let destIndexFile = haddockIndexFile destDir eindexModTime <- liftIO (tryGetModificationTime destIndexFile) let needUpdate = case eindexModTime of @@ -174,7 +173,7 @@ generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do when needUpdate $ do $logInfo (T.concat ["Updating Haddock index for ", descr, " in\n", - T.pack destIndexFile]) + T.pack (show destIndexFile)]) liftIO (mapM_ copyPkgDocs interfaceOpts) readProcessNull (Just destDir) @@ -194,7 +193,7 @@ generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do packageIdentifierString dpPackageIdent FP. (packageNameString name FP.<.> "haddock") destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP) - esrcInterfaceModTime <- tryGetModificationTime (toFilePath srcInterfaceAbsFile) + esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile return $ case esrcInterfaceModTime of Left _ -> Nothing @@ -208,7 +207,7 @@ generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do , srcInterfaceModTime , srcInterfaceAbsFile , destInterfaceAbsFile ) - tryGetModificationTime :: FilePath -> IO (Either () UTCTime) + tryGetModificationTime :: Path Abs File -> IO (Either () UTCTime) tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO () copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do @@ -218,7 +217,7 @@ generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do -- aren't reliably supported on Windows, and (2) the filesystem containing dependencies' -- docs may not be available where viewing the docs (e.g. if building in a Docker -- container). - edestInterfaceModTime <- tryGetModificationTime (toFilePath destInterfaceAbsFile) + edestInterfaceModTime <- tryGetModificationTime destInterfaceAbsFile case edestInterfaceModTime of Left _ -> doCopy Right destInterfaceModTime @@ -226,11 +225,11 @@ generateHaddockIndex descr envOverride wc dumpPackages docRelFP destDir = do | otherwise -> return () where doCopy = do - removeTreeIfExists destHtmlAbsDir - createTree destHtmlAbsDir + ignoringAbsence (removeDirRecur destHtmlAbsDir) + ensureDir destHtmlAbsDir onException - (copyDirectoryRecursive (parent srcInterfaceAbsFile) destHtmlAbsDir) - (removeTreeIfExists destHtmlAbsDir) + (copyDirRecur (parent srcInterfaceAbsFile) destHtmlAbsDir) + (ignoringAbsence (removeDirRecur destHtmlAbsDir)) destHtmlAbsDir = parent destInterfaceAbsFile -- | Find first DumpPackage matching the GhcPkgId diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 04cc77799e..9bc551bdf4 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -63,7 +63,7 @@ import Stack.Constants (wiredInPackages) import Stack.Package import Stack.Types -import System.Directory +import qualified System.Directory as D import System.IO (withBinaryFile, IOMode (ReadMode)) import System.IO.Error (isDoesNotExistError) @@ -176,7 +176,7 @@ parseTargetsFromBuildOpts needTargets bopts = do stackYamlFP <- asks $ bcStackYaml . getBuildConfig parseCustomMiniBuildPlan stackYamlFP url rawLocals <- getLocalPackageViews - workingDir <- getWorkingDir + workingDir <- getCurrentDir let snapshot = mpiVersion <$> mbpPackages mbp0 flagExtraDeps <- convertSnapshotToExtra @@ -532,7 +532,7 @@ getModTimeMaybe fp = (catch (liftM (Just . modTime) - (getModificationTime fp)) + (D.getModificationTime fp)) (\e -> if isDoesNotExistError e then return Nothing diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index d23fbda09a..11c1edae71 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -21,7 +21,7 @@ module Stack.Build.Target import Control.Applicative import Control.Arrow (second) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (MonadCatch, throwM) import Control.Monad.IO.Class import Data.Either (partitionEithers) import Data.Map (Map) @@ -105,7 +105,7 @@ data LocalPackageView = LocalPackageView } -- | Same as @parseRawTarget@, but also takes directories into account. -parseRawTargetDirs :: (MonadIO m, MonadThrow m) +parseRawTargetDirs :: (MonadIO m, MonadCatch m) => Path Abs Dir -- ^ current directory -> Map PackageName LocalPackageView -> Text @@ -114,7 +114,7 @@ parseRawTargetDirs root locals t = case parseRawTarget t of Just rt -> return $ Right [(ri, rt)] Nothing -> do - mdir <- resolveDirMaybe root $ T.unpack t + mdir <- forgivingAbsence (resolveDir root (T.unpack t)) case mdir of Nothing -> return $ Left $ "Directory not found: " `T.append` t Just dir -> @@ -273,7 +273,7 @@ data NeedTargets = NeedTargets | AllowNoTargets -parseTargets :: (MonadThrow m, MonadIO m) +parseTargets :: (MonadCatch m, MonadIO m) => NeedTargets -- ^ need at least one target -> Bool -- ^ using implicit global project? -> Map PackageName Version -- ^ snapshot diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7617ce03b2..c99841c7e1 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -84,8 +84,8 @@ import Stack.Fetch import Stack.Package import Stack.Types import Stack.Types.StackT -import System.Directory (canonicalizePath) -import qualified System.FilePath as FP +import qualified System.Directory as D +import qualified System.FilePath as FP data BuildPlanException = UnknownPackages @@ -448,7 +448,7 @@ loadBuildPlan name = do Right bp -> return bp Left e -> do $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e) - createTree (parent fp) + ensureDir (parent fp) req <- parseUrl $ T.unpack url $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." $logDebug $ "Downloading build plan from: " <> url @@ -917,7 +917,7 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do return cacheFP getYamlFPFromFile url = do - fp <- liftIO $ canonicalizePath $ toFilePath (parent stackYamlFP) FP. T.unpack (fromMaybe url $ + fp <- liftIO $ D.canonicalizePath $ toFilePath (parent stackYamlFP) FP. T.unpack (fromMaybe url $ T.stripPrefix "file://" url <|> T.stripPrefix "file:" url) parseAbsFile fp diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs index 423634e61a..8a2bd3d4ec 100644 --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -9,7 +9,7 @@ module Stack.Clean import Control.Exception (Exception) import Control.Monad (when) -import Control.Monad.Catch (MonadThrow,throwM) +import Control.Monad.Catch (MonadCatch, throwM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader, asks) @@ -18,20 +18,19 @@ import Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Typeable (Typeable) -import Path.IO (removeTreeIfExists) +import Path.IO (ignoringAbsence, removeDirRecur) import Stack.Build.Source (getLocalPackageViews) import Stack.Build.Target (LocalPackageView(..)) import Stack.Constants (distDirFromDir, workDirFromDir) import Stack.Types (HasEnvConfig,PackageName, bcWorkDir, getBuildConfig) - -- | Reset the build, i.e. remove the @dist@ directory -- (for example @.stack-work\/dist\/x84_64-linux\/Cabal-1.22.4.0@) -- for all targets. -- -- Throws 'StackCleanException'. clean - :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) + :: (MonadCatch m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) => CleanOpts -> m () clean (CleanTargets targets) = @@ -40,7 +39,7 @@ clean (CleanFull _ ) = cleanup [] True cleanup - :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) + :: (MonadCatch m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) => [PackageName] -> Bool -> m() cleanup targets doFullClean = do @@ -56,11 +55,11 @@ cleanup targets doFullClean = do if doFullClean then workDirFromDir pkgDir else distDirFromDir pkgDir - removeTreeIfExists =<< delDir + ignoringAbsence . removeDirRecur =<< delDir when doFullClean $ do bconfig <- asks getBuildConfig bcwd <- bcWorkDir bconfig - removeTreeIfExists bcwd + ignoringAbsence (removeDirRecur bcwd) pkgs -> throwM (NonLocalPackages pkgs) -- | Options for cleaning a project. diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index abd0bbe386..6cee6edcee 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -77,7 +77,7 @@ import qualified Stack.Image as Image import Stack.PackageIndex import Stack.Types import Stack.Types.Internal -import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) +import qualified System.Directory as D import System.Environment import System.IO import System.Process.Read @@ -121,7 +121,7 @@ getImplicitGlobalProjectDir config = --TEST no warning printed liftM fst $ tryDeprecatedPath Nothing - dirExists + doesDirExist (implicitGlobalProjectDir stackRoot) (implicitGlobalProjectDirDeprecated stackRoot) where @@ -257,12 +257,12 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c configLocalBin <- case configMonoidLocalBinPath of Nothing -> do - localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir + localDir <- getAppUserDataDir $(mkRelDir "local") return $ localDir $(mkRelDir "bin") Just userPath -> (case mproject of -- Not in a project - Nothing -> parseRelAsAbsDir userPath + Nothing -> resolveDir' userPath -- Resolves to the project dir and appends the user path if it is relative Just (_, configYaml) -> resolveDir (parent configYaml) userPath) -- TODO: Either catch specific exceptions or add a @@ -414,8 +414,8 @@ loadBuildConfig mproject config mresolver mcompiler = do dest = destDir stackDotYaml dest' :: FilePath dest' = toFilePath dest - createTree destDir - exists <- fileExists dest + ensureDir destDir + exists <- doesFileExist dest if exists then do ProjectAndConfigMonoid project _ <- loadYaml dest @@ -486,7 +486,7 @@ loadBuildConfig mproject config mresolver mcompiler = do return $ mbpCompilerVersion mbp ResolverCompiler wantedCompiler -> return wantedCompiler - extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project) + extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) packageCaches <- runReaderT (getMinimalEnvOverride >>= getPackageCaches) miniConfig @@ -553,12 +553,12 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do dir = root dirRel dirTmp = root dirRelTmp - exists <- dirExists dir + exists <- doesDirExist dir unless exists $ do - removeTreeIfExists dirTmp + ignoringAbsence (removeDirRecur dirTmp) let cloneAndExtract commandName resetCommand commit = do - createTree (parent dirTmp) + ensureDir (parent dirTmp) readInNull (parent dirTmp) commandName menv [ "clone" , T.unpack url @@ -602,12 +602,12 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do renameDir dirTmp dir case remotePackageType of - RPTHttp -> do x <- listDirectory dir + RPTHttp -> do x <- listDir dir case x of ([dir'], []) -> return dir' (dirs, files) -> do - removeFileIfExists file - removeTreeIfExists dir + ignoringAbsence (removeFile file) + ignoringAbsence (removeDirRecur dir) throwM $ UnexpectedArchiveContents dirs files _ -> return dir @@ -616,14 +616,10 @@ determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) determineStackRoot = do env <- liftIO getEnvironment case lookup stackRootEnvVar env of - Nothing -> do - x <- liftIO $ getAppUserDataDirectory stackProgName - parseAbsDir x + Nothing -> getAppUserDataDir $(mkRelDir stackProgName) Just x -> do - y <- liftIO $ do - createDirectoryIfMissing True x - canonicalizePath x - parseAbsDir y + liftIO $ D.createDirectoryIfMissing True x + resolveDir' x -- | Determine the extra config file locations which exist. -- @@ -641,7 +637,7 @@ getExtraConfigs userConfigPath = do mstackGlobalConfig <- maybe (return Nothing) (fmap Just . parseAbsFile) $ lookup "STACK_GLOBAL_CONFIG" env - filterM fileExists + filterM doesFileExist $ fromMaybe userConfigPath mstackConfig : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath) @@ -666,16 +662,16 @@ getProjectConfig Nothing = do case lookup "STACK_YAML" env of Just fp -> do $logInfo "Getting project config file from STACK_YAML environment" - liftM Just $ parseRelAsAbsFile fp + liftM Just $ resolveFile' fp Nothing -> do - currDir <- getWorkingDir + currDir <- getCurrentDir search currDir where search dir = do let fp = dir stackDotYaml fp' = toFilePath fp $logDebug $ "Checking for project config at: " <> T.pack fp' - exists <- fileExists fp + exists <- doesFileExist fp if exists then return $ Just fp else do @@ -696,7 +692,7 @@ loadProjectConfig mstackYaml = do mfp <- getProjectConfig mstackYaml case mfp of Just fp -> do - currDir <- getWorkingDir + currDir <- getCurrentDir $logDebug $ "Loading project config file " <> T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp)) load fp @@ -720,7 +716,7 @@ getDefaultGlobalConfigPath = liftM (Just . fst ) $ tryDeprecatedPath (Just "non-project global configuration file") - fileExists + doesFileExist new old (Just new,Nothing) -> return (Just new) @@ -735,11 +731,11 @@ getDefaultUserConfigPath getDefaultUserConfigPath stackRoot = do (path, exists) <- tryDeprecatedPath (Just "non-project configuration file") - fileExists + doesFileExist (defaultUserConfigPath stackRoot) (defaultUserConfigPathDeprecated stackRoot) unless exists $ do - createTree (parent path) + ensureDir (parent path) liftIO $ S.writeFile (toFilePath path) $ S.concat [ "# This file contains default non-project-specific settings for 'stack', used\n" , "# in all projects. For more information about stack's configuration, see\n" @@ -748,6 +744,5 @@ getDefaultUserConfigPath stackRoot = do , Yaml.encode (mempty :: Object) ] return path - packagesParser :: Parser [String] packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed")) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 67be09663f..e1a0886a39 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -47,29 +47,28 @@ import Stack.Build.Target import Stack.Constants import Stack.Package import Stack.Types -import qualified System.Directory as D import System.FilePath (isPathSeparator) import System.Process.Read import Text.Hastache (htmlEscape) import Trace.Hpc.Tix -- | Invoked at the beginning of running with "--coverage" -deleteHpcReports :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) +deleteHpcReports :: (MonadIO m, MonadCatch m, MonadReader env m, HasEnvConfig env) => m () deleteHpcReports = do hpcDir <- hpcReportDir - removeTreeIfExists hpcDir + ignoringAbsence (removeDirRecur hpcDir) -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) => PackageName -> Path Abs File -> String -> m () updateTixFile pkgName tixSrc testName = do - exists <- fileExists tixSrc + exists <- doesFileExist tixSrc when exists $ do tixDest <- tixFilePath pkgName testName - removeFileIfExists tixDest - createTree (parent tixDest) + ignoringAbsence (removeFile tixDest) + ensureDir (parent tixDest) -- Remove exe modules because they are problematic. This could be revisited if there's a GHC -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853 mtix <- readTixOrLog tixSrc @@ -77,7 +76,7 @@ updateTixFile pkgName tixSrc testName = do Nothing -> $logError $ "Failed to read " <> T.pack (toFilePath tixSrc) Just tix -> do liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix) - removeFileIfExists tixSrc + ignoringAbsence (removeFile tixSrc) -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) @@ -138,7 +137,7 @@ generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLog => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m () generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do -- If a .tix file exists, move it to the HPC output directory and generate a report for it. - tixFileExists <- fileExists tixSrc + tixFileExists <- doesFileExist tixSrc if not tixFileExists then $logError $ T.concat [ "Didn't find .tix for " @@ -242,32 +241,33 @@ generateHpcReportForTargets opts = do " is used with a non test-suite target)" STLocalAll -> do pkgPath <- hpcPkgPath name - exists <- dirExists pkgPath + exists <- doesDirExist pkgPath if exists then do - (_, files) <- listDirectory pkgPath + (_, files) <- listDir pkgPath return (filter ((".tix" `isSuffixOf`) . toFilePath) files) else return [] - tixPaths <- liftM (++ targetTixFiles) $ mapM (parseRelAsAbsFile . T.unpack) tixFiles + tixPaths <- liftM (++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles when (null tixPaths) $ fail "Not generating combined report, because no targets or tix files are specified." reportDir <- case hroptsDestDir opts of Nothing -> liftM ( $(mkRelDir "combined/custom")) hpcReportDir Just destDir -> do - liftIO $ D.createDirectoryIfMissing True destDir - parseRelAsAbsDir destDir + dest <- resolveDir' destDir + ensureDir dest + return dest generateUnionReport "combined report" reportDir tixPaths generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) => m () generateHpcUnifiedReport = do outputDir <- hpcReportDir - createTree outputDir - (dirs, _) <- listDirectory outputDir + ensureDir outputDir + (dirs, _) <- listDir outputDir tixFiles <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do - (dirs', _) <- listDirectory dir + (dirs', _) <- listDir dir forM dirs' $ \dir' -> do - (_, files) <- listDirectory dir' + (_, files) <- listDir dir' return (filter ((".tix" `isSuffixOf`) . toFilePath) files) let reportDir = outputDir $(mkRelDir "combined/all") if length tixFiles < 2 @@ -288,7 +288,7 @@ generateUnionReport report reportDir tixFiles = do "The following modules are left out of the " : report : " due to version mismatches: " : intersperse ", " (map T.pack errs) tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix") - createTree (parent tixDest) + ensureDir (parent tixDest) liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] @@ -321,13 +321,13 @@ generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch generateHpcMarkupIndex = do outputDir <- hpcReportDir let outputFile = outputDir $(mkRelFile "index.html") - createTree outputDir - (dirs, _) <- listDirectory outputDir + ensureDir outputDir + (dirs, _) <- listDir outputDir rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do - (subdirs, _) <- listDirectory dir + (subdirs, _) <- listDir dir forM subdirs $ \subdir -> do let indexPath = subdir $(mkRelFile "hpc_index.html") - exists' <- fileExists indexPath + exists' <- doesFileExist indexPath if not exists' then return Nothing else do relPath <- stripDir outputDir indexPath let package = dirname dir @@ -372,7 +372,7 @@ generateHpcMarkupIndex = do generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () generateHpcErrorReport dir err = do - createTree dir + ensureDir dir liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat [ "" , "

HPC Report Generation Error

" @@ -397,7 +397,7 @@ findPackageKeyForBuiltPackage pkgDir pkgId = do distDir <- distDirFromDir pkgDir path <- liftM (distDir ) $ parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf") - exists <- fileExists path + exists <- doesFileExist path if exists then do contents <- liftIO $ T.readFile (toFilePath path) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 710d0433fc..a55174a481 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -56,7 +56,7 @@ import GHC.Exts (sortWith) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Extra (toFilePathNoTrailingSep) -import Path.IO +import Path.IO hiding (canonicalizePath) import qualified Paths_stack as Meta import Prelude -- Fix redundant import warnings import Stack.Constants @@ -64,7 +64,7 @@ import Stack.Docker.GlobalDB import Stack.Types import Stack.Types.Internal import Stack.Setup (ensureDockerStackExe) -import System.Directory (canonicalizePath,getModificationTime,getHomeDirectory) +import System.Directory (canonicalizePath,getHomeDirectory) import System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath ,lookupEnv) import System.Exit (exitSuccess, exitWith) @@ -142,7 +142,7 @@ reexecWithOptionalContainer mprojectRoot = (exePath,exeTimestamp,misCompatible) <- liftIO $ do exePath <- liftIO getExecutablePath - exeTimestamp <- liftIO (getModificationTime exePath) + exeTimestamp <- resolveFile' exePath >>= getModificationTime isKnown <- liftIO $ getDockerImageExe @@ -265,7 +265,7 @@ runContainerAndExit getCmdArgs <*> (parseAbsDir =<< getHomeDirectory) isStdoutTerminal <- asks getTerminal let sshDir = homeDir sshRelDir - sshDirExists <- dirExists sshDir + sshDirExists <- doesDirExist sshDir let dockerHost = lookup "DOCKER_HOST" env dockerCertPath = lookup "DOCKER_CERT_PATH" env bamboo = lookup "bamboo_buildKey" env @@ -309,10 +309,10 @@ runContainerAndExit getCmdArgs $(mkRelDir ".local/bin")] (T.pack <$> lookupImageEnv "PATH" imageEnvVars) (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker - pwd <- getWorkingDir + pwd <- getCurrentDir liftIO (do updateDockerImageLastUsed config iiId (toFilePath projectRoot) - mapM_ createTree [sandboxHomeDir, stackRoot]) + mapM_ (ensureDir) [sandboxHomeDir, stackRoot]) containerID <- (trim . decodeUtf8) <$> readDockerProcess envOverride (concat @@ -754,19 +754,19 @@ entrypoint config@Config{..} DockerEntrypoint{..} = -- its original home directory to the host's stack root, to avoid needing to download them origStackHomeDir <- parseAbsDir (User.homeDirectory ue) let origStackRoot = origStackHomeDir $(mkRelDir ("." ++ stackProgName)) - buildPlanDirExists <- dirExists (buildPlanDir origStackRoot) + buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot) when buildPlanDirExists $ do - (_, buildPlans) <- listDirectory (buildPlanDir origStackRoot) + (_, buildPlans) <- listDir (buildPlanDir origStackRoot) forM_ buildPlans $ \srcBuildPlan -> do let destBuildPlan = buildPlanDir configStackRoot filename srcBuildPlan - exists <- fileExists destBuildPlan + exists <- doesFileExist destBuildPlan unless exists $ do - createTree (parent destBuildPlan) + ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan forM_ configPackageIndices $ \pkgIdx -> do msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do srcIndex <- configPackageIndex (indexName pkgIdx) - exists <- fileExists srcIndex + exists <- doesFileExist srcIndex return $ if exists then Just srcIndex else Nothing @@ -775,9 +775,9 @@ entrypoint config@Config{..} DockerEntrypoint{..} = Just srcIndex -> do flip runReaderT config $ do destIndex <- configPackageIndex (indexName pkgIdx) - exists <- fileExists destIndex + exists <- doesFileExist destIndex unless exists $ do - createTree (parent destIndex) + ensureDir (parent destIndex) copyFile srcIndex destIndex return True where @@ -835,12 +835,12 @@ removeDirectoryContents :: Path Abs Dir -- ^ Directory to remove contents of -> [Path Rel File] -- ^ Top-level file names to exclude from removal -> IO () removeDirectoryContents path excludeDirs excludeFiles = - do isRootDir <- dirExists path + do isRootDir <- doesDirExist path when isRootDir - (do (lsd,lsf) <- listDirectory path + (do (lsd,lsf) <- listDir path forM_ lsd (\d -> unless (dirname d `elem` excludeDirs) - (removeTree d)) + (removeDirRecur d)) forM_ lsf (\f -> unless (filename f `elem` excludeFiles) (removeFile f))) @@ -1090,6 +1090,5 @@ type GetCmdArgs env m -> Bool -> m (FilePath,[String],[(String,String)],[Mount]) - type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m ,HasConfig env,HasTerminal env,HasReExec env,HasHttpManager env,MonadMask m) diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs index 1aa8842a38..e044b56753 100644 --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -29,7 +29,7 @@ import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH import Path (toFilePath, parent) -import Path.IO (createTree) +import Path.IO (ensureDir) import Stack.Types.Config import Stack.Types.Docker @@ -100,7 +100,7 @@ setDockerImageExe config imageId exePath exeTimestamp compatible = withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a withGlobalDB config action = do let db = dockerDatabasePath (configDocker config) - createTree (parent db) + ensureDir (parent db) runSqlite (T.pack (toFilePath db)) (do _ <- runMigrationSilent migrateTables action) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 0352f15f2f..b8ae815f84 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -65,15 +65,12 @@ import Data.Typeable (Typeable) import Data.Word (Word64) import Network.HTTP.Download import Path -import Path.IO (dirExists, createTree) +import Path.IO import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.PackageIndex import Stack.Types -import System.Directory (canonicalizePath, - createDirectoryIfMissing, - doesDirectoryExist, - renameDirectory) +import qualified System.Directory as D import System.FilePath ((<.>)) import qualified System.FilePath as FP import System.IO (IOMode (ReadMode), @@ -140,7 +137,7 @@ unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpM -> [String] -- ^ names or identifiers -> m () unpackPackages menv dest input = do - dest' <- liftIO (canonicalizePath dest) >>= parseAbsDir + dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs @@ -384,7 +381,7 @@ getToFetch mdest resolvedAll = do case mdestDir of Nothing -> return Nothing Just destDir -> do - exists <- dirExists destDir + exists <- doesDirExist destDir return $ if exists then Just destDir else Nothing case mexists of Just destDir -> return $ Right (ident, destDir) @@ -465,7 +462,7 @@ fetchPackages' mdistDir toFetchAll = do let dest = toFilePath $ parent destDir innerDest = toFilePath destDir - liftIO $ createDirectoryIfMissing True dest + liftIO $ ensureDir (parent destDir) liftIO $ withBinaryFile fp ReadMode $ \h -> do -- Avoid using L.readFile, which is more likely to leak @@ -498,15 +495,15 @@ fetchPackages' mdistDir toFetchAll = do let inner = dest FP. identStr oldDist = inner FP. "dist" newDist = inner FP. toFilePath distDir - exists <- doesDirectoryExist oldDist + exists <- D.doesDirectoryExist oldDist when exists $ do -- Previously used takeDirectory, but that got confused -- by trailing slashes, see: -- https://github.com/commercialhaskell/stack/issues/216 -- -- Instead, use Path which is a bit more resilient - createTree . parent =<< parseAbsDir newDist - renameDirectory oldDist newDist + ensureDir . parent =<< parseAbsDir newDist + D.renameDirectory oldDist newDist let cabalFP = innerDest FP. diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 26d604a848..d6513e5e72 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -32,25 +32,24 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir) +import Path (Path, Abs, Dir, toFilePath, parent) import Path.Extra (toFilePathNoTrailingSep) -import Path.IO (dirExists, createTree) +import Path.IO import Prelude hiding (FilePath) import Stack.Constants import Stack.Types -import System.Directory (canonicalizePath) import System.FilePath (searchPathSeparator) import System.Process.Read -- | Get the global package database -getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) +getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Path Abs Dir) getGlobalDB menv wc = do -- This seems like a strange way to get the global package database -- location, but I don't know of a better one bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return let fp = S8.unpack $ stripTrailingColon $ firstLine bs - liftIO (canonicalizePath fp) >>= parseAbsDir + resolveDir' fp where stripTrailingColon bs | S8.null bs = bs @@ -80,12 +79,12 @@ ghcPkg menv wc pkgDbs args = do createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () createDatabase menv wc db = do - exists <- dirExists db + exists <- doesDirExist db unless exists $ do -- Creating the parent doesn't seem necessary, as ghc-pkg -- seems to be sufficiently smart. But I don't feel like -- finding out it isn't the hard way - createTree (parent db) + ensureDir (parent db) _ <- tryProcessStdout Nothing menv (ghcPkgExeName wc) ["init", toFilePath db] return () diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index d2777b747d..88d595ea82 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -54,7 +54,6 @@ import Stack.Exec import Stack.Package import Stack.Types import Stack.Types.Internal -import System.Directory (getTemporaryDirectory) import Text.Read (readMaybe) #ifndef WINDOWS @@ -156,8 +155,7 @@ ghci opts@GhciOpts{..} = do -- include CWD. "-i" : odir <> pkgopts <> ghciArgs <> extras) - tmp <- liftIO getTemporaryDirectory - withCanonicalizedTempDirectory tmp "ghci" $ \tmpDir -> do + withSystemTempDir "ghci" $ \tmpDir -> do let macrosFile = tmpDir $(mkRelFile "cabal_macros.h") macrosOpts <- preprocessCabalMacros pkgs macrosFile if ghciNoLoadModules diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs index 7dfbcd42c2..e397d8c551 100644 --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -49,7 +49,7 @@ ide targets useropts = do , boptsBuildSubset = BSOnlyDependencies } (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts bopts) - pwd <- getWorkingDir + pwd <- getCurrentDir (pkgopts,_srcfiles) <- liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd localdb <- packageDatabaseLocal @@ -96,7 +96,7 @@ getPackageOptsAndTargetFiles pwd pkg = do (autogen ) (parseRelFile ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs")) - paths_foo_exists <- fileExists paths_foo + paths_foo_exists <- doesFileExist paths_foo let ghcOptions bio = bioOneWordOpts bio ++ bioOpts bio ++ diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index cb34f419cb..d557fc483a 100644 --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -41,11 +41,11 @@ type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCat stageContainerImageArtifacts :: Build e m => m () stageContainerImageArtifacts = do config <- asks getConfig - workingDir <- getWorkingDir + workingDir <- getCurrentDir forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do imageDir <- imageStagingDir workingDir idx - removeTreeIfExists imageDir - createTree imageDir + ignoringAbsence (removeDirRecur imageDir) + ensureDir imageDir stageExesInDir opts imageDir syncAddContentToDir opts imageDir @@ -56,7 +56,7 @@ stageContainerImageArtifacts = do createContainerImageFromStage :: Assemble e m => m () createContainerImageFromStage = do config <- asks getConfig - workingDir <- getWorkingDir + workingDir <- getCurrentDir forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do imageDir <- imageStagingDir workingDir idx createDockerImage opts imageDir @@ -70,9 +70,9 @@ stageExesInDir opts dir = do liftM ( $(mkRelDir "bin")) installationRootLocal let destBinPath = dir $(mkRelDir "usr/local/bin") - createTree destBinPath + ensureDir destBinPath case imgDockerExecutables opts of - Nothing -> copyDirectoryRecursive srcBinPath destBinPath + Nothing -> copyDirRecur srcBinPath destBinPath Just exes -> forM_ exes $ \exe -> do exeRelFile <- parseRelFile exe copyFile (srcBinPath exeRelFile) (destBinPath exeRelFile) @@ -89,8 +89,8 @@ syncAddContentToDir opts dir = do do sourcePath <- parseRelDir source destPath <- parseAbsDir dest let destFullPath = dir dropRoot destPath - createTree destFullPath - copyDirectoryRecursive + ensureDir destFullPath + copyDirRecur (bcRoot bconfig sourcePath) destFullPath) @@ -120,7 +120,6 @@ createDockerImage dockerConfig dir = do , toFilePathNoTrailingSep dir] callProcess $ Cmd Nothing "docker" menv args - -- | Extend the general purpose docker image with entrypoints (if -- specified). extendDockerImageWithEntrypoint :: Assemble e m => ImageDockerOpts -> Path Abs Dir -> m () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index e8c69ccced..a5d73e4c8c 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -9,7 +9,7 @@ module Stack.Init import Control.Exception (assert) import Control.Exception.Enclosed (catchAny) -import Control.Monad (when) +import Control.Monad import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger @@ -40,7 +40,6 @@ import Stack.Solver import Stack.Types import Stack.Types.Internal ( HasTerminal, HasReExec , HasLogLevel) -import System.Directory (makeRelativeToCurrentDirectory) import Stack.Config ( getSnapshots , makeConcreteResolver) import qualified System.FilePath as FP @@ -57,11 +56,10 @@ initProject -> m () initProject currDir initOpts mresolver = do let dest = currDir stackDotYaml - dest' = toFilePath dest - reldest <- liftIO $ makeRelativeToCurrentDirectory dest' + reldest <- toFilePath `liftM` makeRelativeToCurrentDir dest - exists <- fileExists dest + exists <- doesFileExist dest when (not (forceOverwrite initOpts) && exists) $ do error ("Stack configuration file " <> reldest <> " exists, use 'stack solver' to fix the existing config file or \ @@ -125,7 +123,7 @@ initProject currDir initOpts mresolver = do | otherwise -> assert False $ toFilePath dir Just rel -> toFilePath rel - makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath + makeRel = fmap toFilePath . makeRelativeToCurrentDir pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) toPkg dir = PackageEntry @@ -161,7 +159,7 @@ initProject currDir initOpts mresolver = do (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") <> T.pack reldest - liftIO $ L.writeFile dest' + liftIO $ L.writeFile (toFilePath dest) $ B.toLazyByteString $ renderStackYaml p (Map.elems $ fmap (makeRelDir . parent . fst) ignored) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index eb6601e76b..88ab86d9c1 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -79,11 +79,11 @@ new :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r, Functor m, Applicative m) => NewOpts -> m (Path Abs Dir) new opts = do - pwd <- getWorkingDir + pwd <- getCurrentDir absDir <- if bare then return pwd else do relDir <- parseRelDir (packageNameString project) liftM (pwd ) (return relDir) - exists <- dirExists absDir + exists <- doesDirExist absDir configTemplate <- configDefaultTemplate <$> asks getConfig let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate , configTemplate @@ -151,7 +151,7 @@ loadTemplate name logIt = do loadLocalFile path = do $logDebug ("Opening local template: \"" <> T.pack (toFilePath path) <> "\"") - exists <- fileExists path + exists <- doesFileExist path if exists then liftIO (T.readFile (toFilePath path)) else throwM (FailedToLoadTemplate name (toFilePath path)) @@ -238,7 +238,7 @@ writeTemplateFiles files = forM_ (M.toList files) (\(fp,bytes) -> - do createTree (parent fp) + do ensureDir (parent fp) liftIO (LB.writeFile (toFilePath fp) bytes)) -- | Run any initialization functions, such as Git. diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index ef8b553864..fbfd694364 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -50,7 +50,6 @@ import Control.Monad.Logger (MonadLogger,logWarn) import Control.Monad.Reader import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 -import Data.Either import Data.Function import Data.List import Data.List.Extra (nubOrd) @@ -83,14 +82,14 @@ import qualified Distribution.Verbosity as D import Path as FL import Path.Extra import Path.Find -import Path.IO +import Path.IO hiding (findFiles) import Prelude import Safe (headDef, tailSafe) import Stack.Build.Installed import Stack.Constants import Stack.Types import qualified Stack.Types.PackageIdentifier -import System.Directory (doesFileExist, getDirectoryContents) +import qualified System.Directory as D import System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error @@ -249,7 +248,7 @@ generatePkgDescOpts generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do distDir <- distDirFromDir cabalDir let cabalMacros = autogenDir distDir $(mkRelFile "cabal_macros.h") - exists <- fileExists cabalMacros + exists <- doesFileExist cabalMacros let mcabalMacros = if exists then Just cabalMacros @@ -587,7 +586,7 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of ++ " If a wildcard is used it must be with an file extension." Just (NoGlob filepath') -> return [filepath'] Just (FileGlob dir' ext) -> do - files <- getDirectoryContents (dir FilePath. dir') + files <- D.getDirectoryContents (dir FilePath. dir') case [ dir' FilePath. file | file <- files , let (name, ext') = splitExtensions file @@ -598,7 +597,7 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of -- | Get all files referenced by the benchmark. benchmarkFiles - :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) @@ -621,7 +620,7 @@ benchmarkFiles bench = do -- | Get all files referenced by the test. testFiles - :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) => TestSuite -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do @@ -646,7 +645,7 @@ testFiles test = do -- | Get all files referenced by the executable. executableFiles - :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) => Executable -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do @@ -666,7 +665,7 @@ executableFiles exe = do -- | Get all files referenced by the library. libraryFiles - :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) @@ -686,7 +685,7 @@ libraryFiles lib = do build = libBuildInfo lib -- | Get all C sources and extra source files in a build. -buildOtherSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m) +buildOtherSources :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader (Path Abs File, Path Abs Dir) m) => BuildInfo -> m (Set DotCabalPath) buildOtherSources build = do csources <- liftM @@ -894,7 +893,7 @@ getDependencies component dotCabalPath = FilePath.replaceExtension (toFilePath (dumpHIDir fileRel)) ".dump-hi" - dumpHIExists <- liftIO $ doesFileExist dumpHIPath + dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath if dumpHIExists then parseDumpHI dumpHIPath else return (S.empty, []) @@ -977,29 +976,20 @@ findCandidate dirs exts name = do DotCabalCFile{} -> DotCabalCFilePath paths_pkg pkg = "Paths_" ++ packageNameString pkg makeNameCandidates = - liftM (nubOrd . rights . concat) (mapM makeDirCandidates dirs) + liftM (nubOrd . catMaybes . concat) (mapM makeDirCandidates dirs) makeDirCandidates :: Path Abs Dir - -> IO [Either ResolveException (Path Abs File)] + -> IO [Maybe (Path Abs File)] makeDirCandidates dir = case name of - DotCabalMain fp -> liftM return (try (resolveFile' dir fp)) - DotCabalFile fp -> liftM return (try (resolveFile' dir fp)) - DotCabalCFile fp -> liftM return (try (resolveFile' dir fp)) + DotCabalMain fp -> return `liftM` forgivingAbsence (resolveFile dir fp) + DotCabalFile fp -> return `liftM` forgivingAbsence (resolveFile dir fp) + DotCabalCFile fp -> return `liftM` forgivingAbsence (resolveFile dir fp) DotCabalModule mn -> mapM ((\ ext -> - try (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext))) + forgivingAbsence (resolveFile dir (Cabal.toFilePath mn ++ "." ++ ext))) . T.unpack) exts - resolveFile' - :: (MonadIO m, MonadThrow m) - => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) - resolveFile' x y = do - p <- parseCollapsedAbsFile (toFilePath x FilePath. y) - exists <- fileExists p - if exists - then return p - else throwM $ ResolveFileFailed x y (toFilePath p) -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. @@ -1044,7 +1034,7 @@ logPossibilities dirs mn = do makePossibilities name = mapM (\dir -> - do (_,files) <- listDirectory dir + do (_,files) <- listDir dir return (map filename @@ -1085,13 +1075,13 @@ buildLogPath package' msuffix = do return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn -resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m) +resolveOrWarn :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) => Text -> (Path Abs Dir -> String -> m (Maybe a)) -> FilePath.FilePath -> m (Maybe a) resolveOrWarn subject resolver path = - do cwd <- getWorkingDir + do cwd <- getCurrentDir file <- asks fst dir <- asks (parent . fst) result <- resolver dir path @@ -1104,17 +1094,19 @@ resolveOrWarn subject resolver path = -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveFileOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs File)) -resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe +resolveFileOrWarn = resolveOrWarn "File" f + where f p x = forgivingAbsence (resolveFile p x) -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveDirOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs Dir)) -resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe +resolveDirOrWarn = resolveOrWarn "Directory" f + where f p x = forgivingAbsence (resolveDir p x) -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path. diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 4c48c75d57..030ef50c9e 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -50,7 +50,7 @@ import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Path -import Path.IO (createTree) +import Path.IO (ensureDir) import Path.Extra (toFilePathNoTrailingSep) import Prelude -- Fix AMP warning import Stack.GhcPkg @@ -135,7 +135,7 @@ loadInstalledCache path = do -- | Save a @InstalledCache@ to disk saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () saveInstalledCache path (InstalledCache ref) = liftIO $ do - createTree (parent path) + ensureDir (parent path) readIORef ref >>= taggedEncodeFile path -- | Prune a list of possible packages down to those whose dependencies are met. diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 2b7075a793..cab5824567 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -53,7 +53,6 @@ import Data.Traversable (forM) import Data.Typeable (Typeable) - import Network.HTTP.Download import Path (mkRelDir, parent, parseRelDir, toFilePath, @@ -177,20 +176,20 @@ instance Show PackageIndexException where -- | Require that an index be present, updating if it isn't. requireIndex :: (MonadIO m,MonadLogger m - ,MonadThrow m,MonadReader env m,HasHttpManager env + ,MonadReader env m,HasHttpManager env ,HasConfig env,MonadBaseControl IO m,MonadCatch m) => EnvOverride -> PackageIndex -> m () requireIndex menv index = do tarFile <- configPackageIndex $ indexName index - exists <- fileExists tarFile + exists <- doesFileExist tarFile unless exists $ updateIndex menv index -- | Update all of the package indices updateAllIndices :: (MonadIO m,MonadLogger m - ,MonadThrow m,MonadReader env m,HasHttpManager env + ,MonadReader env m,HasHttpManager env ,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m () @@ -199,7 +198,7 @@ updateAllIndices menv = -- | Update the index tarball updateIndex :: (MonadIO m,MonadLogger m - ,MonadThrow m,MonadReader env m,HasHttpManager env + ,MonadReader env m,HasHttpManager env ,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> PackageIndex @@ -216,7 +215,7 @@ updateIndex menv index = (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name) -- | Update the index Git repo and the index tarball -updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m) +updateIndexGit :: (MonadIO m,MonadLogger m,MonadReader env m,HasConfig env,MonadBaseControl IO m, MonadCatch m) => EnvOverride -> IndexName -> PackageIndex @@ -225,7 +224,7 @@ updateIndexGit :: (MonadIO m,MonadLogger m,MonadThrow m,MonadReader env m,HasCon updateIndexGit menv indexName' index gitUrl = do tarFile <- configPackageIndex indexName' let idxPath = parent tarFile - createTree idxPath + ensureDir idxPath do repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl let cloneArgs = @@ -241,7 +240,7 @@ updateIndexGit menv indexName' index gitUrl = do sDir $(mkRelDir "git-update") acfDir = suDir repoName - repoExists <- dirExists acfDir + repoExists <- doesDirExist acfDir unless repoExists (readInNull suDir "git" menv cloneArgs Nothing) $logSticky "Fetching package index ..." @@ -249,12 +248,12 @@ updateIndexGit menv indexName' index gitUrl = do -- we failed, so wipe the directory and try again, see #1418 $logWarn (T.pack (show ex)) $logStickyDone "Failed to fetch package index, retrying." - removeTree acfDir + removeDirRecur acfDir readInNull suDir "git" menv cloneArgs Nothing $logSticky "Fetching package index ..." readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing $logStickyDone "Fetched package index." - removeFileIfExists tarFile + ignoringAbsence (removeFile tarFile) when (indexGpgVerify index) (readInNull acfDir "git" @@ -297,7 +296,7 @@ updateIndexHTTP indexName' index url = do toUnpack <- if wasDownloaded then return True - else liftM not $ fileExists tar + else not `liftM` doesFileExist tar when toUnpack $ do let tmp = toFilePath tar <.> "tmp" diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index f7ebf8ae1b..f6fb30bbea 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -46,7 +46,7 @@ import Distribution.Version (simplifyVersionRange, orLaterVersion, ear import Distribution.Version.Extra import Network.HTTP.Client.Conduit (HasHttpManager) import Path -import Path.IO +import Path.IO hiding (getModificationTime, getPermissions) import Prelude -- Fix redundant import warnings import Stack.Build (mkBaseConfigOpts) import Stack.Build.Execute @@ -57,8 +57,7 @@ import Stack.Constants import Stack.Package import Stack.Types import Stack.Types.Internal -import System.Directory (getModificationTime, getPermissions, Permissions(..)) -import System.IO.Temp (withSystemTempDirectory) +import System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP -- | Special exception to throw when you want to fail because of bad results @@ -151,7 +150,6 @@ getCabalLbs pvpBounds fp = do Just (_, installed) -> Just (installedVersion installed) Nothing -> Nothing - addUpper version = intersectVersionRanges (earlierVersion $ toCabalVersion $ nextMajorVersion version) addLower version = intersectVersionRanges @@ -201,7 +199,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 = - withCanonicalizedSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do + withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do menv <- getMinimalEnvOverride let bopts = defaultBuildOpts baseConfigOpts <- mkBaseConfigOpts bopts @@ -296,8 +294,7 @@ checkSDistTarball' :: (MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, Monad => String -- ^ Tarball name -> L.ByteString -- ^ Tarball contents as a byte string -> m () -checkSDistTarball' name bytes = withSystemTempDirectory "stack" $ \tdir -> do - tpath <- parseAbsDir tdir +checkSDistTarball' name bytes = withSystemTempDir "stack" $ \tpath -> do npath <- (tpath ) `liftM` parseRelFile name liftIO $ L.writeFile (toFilePath npath) bytes checkSDistTarball npath @@ -306,8 +303,7 @@ withTempTarGzContents :: (MonadIO m, MonadMask m, MonadThrow m) => Path Abs File -- ^ Location of tarball -> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents -> m a -withTempTarGzContents apath f = withSystemTempDirectory "stack" $ \tdir -> do - tpath <- parseAbsDir tdir +withTempTarGzContents apath f = withSystemTempDir "stack" $ \tpath -> do archive <- liftIO $ L.readFile (toFilePath apath) liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive f tpath diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index e8fccf9896..c9e6a5e56c 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -68,7 +68,7 @@ import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path import Path.Extra (toFilePathNoTrailingSep) -import Path.IO +import Path.IO hiding (findExecutable) import qualified Paths_stack as Meta import Prelude hiding (concat, elem, any) -- Fix AMP warning import Safe (readMay) @@ -446,7 +446,7 @@ ensureDockerStackExe containerPlatform = do stackVersion = fromCabalVersion Meta.version tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion) stackExePath <- ( $(mkRelFile "stack")) <$> installDir programsPath tool - stackExeExists <- fileExists stackExePath + stackExeExists <- doesFileExist stackExePath unless stackExeExists $ do $logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"] @@ -492,7 +492,7 @@ upgradeCabal menv wc = do , T.pack $ versionString newest , ". I'm not upgrading Cabal." ] - else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do + else withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do $logInfo $ T.concat [ "Installing Cabal-" , T.pack $ versionString newest @@ -784,7 +784,7 @@ installGHCPosix version _ archiveFile archiveType destDir = do $logDebug $ "make: " <> T.pack makeTool $logDebug $ "tar: " <> T.pack tarTool - withCanonicalizedSystemTempDirectory "stack-setup" $ \root -> do + withSystemTempDir "stack-setup" $ \root -> do dir <- liftM (root ) $ parseRelDir $ @@ -847,7 +847,7 @@ installGHCJS si archiveFile archiveType destDir = do $logDebug $ "ziptool: " <> T.pack zipTool $logDebug $ "tar: " <> T.pack tarTool return $ do - removeTreeIfExists unpackDir + ignoringAbsence (removeDirRecur unpackDir) readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir @@ -859,7 +859,7 @@ installGHCJS si archiveFile archiveType destDir = do $logSticky "Setting up GHCJS build environment" let stackYaml = unpackDir $(mkRelFile "stack.yaml") destBinDir = destDir $(mkRelDir "bin") - createTree destBinDir + ensureDir destBinDir envConfig <- loadGhcjsEnvConfig stackYaml destBinDir -- On windows we need to copy options files out of the install dir. Argh! @@ -875,10 +875,10 @@ installGHCJS si archiveFile archiveType destDir = do build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True } -- Copy over *.options files needed on windows. forM_ mwindowsInstallDir $ \dir -> do - (_, files) <- listDirectory (dir $(mkRelDir "bin")) + (_, files) <- listDir (dir $(mkRelDir "bin")) forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do let dest = destDir $(mkRelDir "bin") filename optionsFile - removeFileIfExists dest + ignoringAbsence (removeFile dest) copyFile optionsFile dest $logStickyDone "Installed GHCJS." @@ -895,7 +895,7 @@ installDockerStackExe _ archiveFile _ destDir = do checkDependencies $ (,) <$> checkDependency "gzip" <*> checkDependency "tar" menv <- getMinimalEnvOverride - createTree destDir + ensureDir destDir readInNull destDir tarTool @@ -924,14 +924,14 @@ ensureGhcjsBooted menv cv shouldBoot = do -- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783 -- This only affects the case where GHCJS has been -- installed with an older version and not yet booted. - stackYamlExists <- fileExists stackYaml + stackYamlExists <- doesFileExist stackYaml actualStackYaml <- if stackYamlExists then return stackYaml else case cv of GhcjsVersion version _ -> liftM ((destDir $(mkRelDir "src")) ) $ parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml" _ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion" - actualStackYamlExists <- fileExists actualStackYaml + actualStackYamlExists <- doesFileExist actualStackYaml unless actualStackYamlExists $ fail "Couldn't find GHCJS stack.yaml in old or new location." bootGhcjs actualStackYaml destDir @@ -1103,12 +1103,12 @@ withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do Just x -> parseAbsFile $ T.unpack x run7z <- setup7z si let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" - createTree (parent destDir) - withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do + ensureDir (parent destDir) + withTempDir (parent destDir) tmpName $ \tmpDir -> do absSrcDir <- case msrcDir of Just srcDir -> return $ tmpDir srcDir Nothing -> expectSingleUnpackedDir archiveFile tmpDir - removeTreeIfExists destDir + ignoringAbsence (removeDirRecur destDir) run7z (parent archiveFile) archiveFile run7z tmpDir tarFile removeFile tarFile `catchIO` \e -> @@ -1122,7 +1122,7 @@ withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir) expectSingleUnpackedDir archiveFile destDir = do - contents <- listDirectory destDir + contents <- listDir destDir case contents of ([dir], []) -> return dir _ -> error $ "Expected a single directory within unpacked " ++ toFilePath archiveFile @@ -1277,13 +1277,12 @@ chunksOverTime diff = do else put (lastTime, acc') go - -- | Perform a basic sanity check of GHC sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler -> m () -sanityCheck menv wc = withCanonicalizedSystemTempDirectory "stack-sanity-check" $ \dir -> do +sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do let fp = toFilePath $ dir $(mkRelFile "Main.hs") liftIO $ writeFile fp $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 5840ae8afe..c7a58f1052 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -63,20 +63,20 @@ markInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" liftIO $ writeFile (toFilePath $ programsPath fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) +unmarkInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadCatch m) => Path Abs Dir -> Tool -> m () unmarkInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" - removeFileIfExists $ programsPath fpRel + ignoringAbsence (removeFile $ programsPath fpRel) listInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => Path Abs Dir -> m [Tool] listInstalled programsPath = do - createTree programsPath - (_, files) <- listDirectory programsPath + ensureDir programsPath + (_, files) <- listDir programsPath return $ mapMaybe toTool files where toTool fp = do diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index da177b5ae8..22480c5745 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -133,6 +133,6 @@ withStackWorkTempDir projectRoot f = do workDir <- getWorkDir let tempDir = projectRoot workDir $(mkRelDir "tmp") uuidPath bracket - (createTree tempDir) - (const (removeTree tempDir)) + (ensureDir tempDir) + (const (removeDirRecur tempDir)) (const (f tempDir)) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index eb383d0bd9..d31a0122e4 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -47,7 +47,7 @@ import qualified Distribution.Text as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.Find (findFiles) -import Path.IO (getWorkingDir, parseRelAsAbsDir) +import Path.IO hiding (findExecutable, findFiles) import Prelude import Stack.BuildPlan import Stack.Constants (stackDotYaml) @@ -59,12 +59,8 @@ import Stack.Types import Stack.Types.Internal ( HasTerminal , HasReExec , HasLogLevel) -import System.Directory (copyFile, - createDirectoryIfMissing, - getTemporaryDirectory, - makeRelativeToCurrentDirectory) +import qualified System.Directory as D import qualified System.FilePath as FP -import System.IO.Temp (withSystemTempDirectory) import System.Process.Read data ConstraintType = Constraint | Preference deriving (Eq) @@ -80,9 +76,10 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, Mo -> m (Either [PackageName] ConstraintSpec) cabalSolver menv cabalfps constraintType srcConstraints depConstraints cabalArgs = - withSystemTempDirectory "cabal-solver" $ \dir -> do + withSystemTempDir "cabal-solver" $ \dir' -> do let versionConstraints = fmap fst depConstraints + dir = toFilePath dir' configLines <- getCabalConfig dir constraintType versionConstraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -93,7 +90,7 @@ cabalSolver menv cabalfps constraintType -- -- In theory we could use --ignore-sandbox, but not all versions of cabal -- support it. - tmpdir <- liftIO getTemporaryDirectory >>= parseRelAsAbsDir + tmpdir <- getTempDir let args = ("--config-file=" ++ configFile) : "install" @@ -227,8 +224,8 @@ getCabalConfig dir constraintType constraints = do let dstdir = dir FP. T.unpack (indexNameText $ indexName index) dst = dstdir FP. "00-index.tar" liftIO $ void $ tryIO $ do - createDirectoryIfMissing True dstdir - copyFile (toFilePath src) dst + D.createDirectoryIfMissing True dstdir + D.copyFile (toFilePath src) dst return $ T.concat [ "remote-repo: " , indexNameText $ indexName index @@ -511,7 +508,7 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do when (null cabalfps) $ error noPkgMsg - relpaths <- mapM makeRel cabalfps + relpaths <- mapM makeRelativeToCurrentDir cabalfps $logInfo $ "Using cabal packages:" $logInfo $ T.pack (formatGroup relpaths) @@ -531,7 +528,7 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do nameMismatchPkgs = mapMaybe getNameMismatchPkg packages when (nameMismatchPkgs /= []) $ do - rels <- mapM makeRel nameMismatchPkgs + rels <- mapM makeRelativeToCurrentDir nameMismatchPkgs error $ "Package name as defined in the .cabal file must match the \ \.cabal file name.\n\ \Please fix the following packages and try again:\n" @@ -549,7 +546,7 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do unique = packages \\ dupIgnored when (dupIgnored /= []) $ do - dups <- mapM (mapM (makeRel . fst)) (dupGroups packages) + dups <- mapM (mapM (makeRelativeToCurrentDir . fst)) (dupGroups packages) $logWarn $ T.pack $ "Following packages have duplicate package names:\n" <> intercalate "\n" (map formatGroup dups) @@ -560,23 +557,22 @@ cabalPackagesCheck cabalfps noPkgMsg dupErrMsg = do Just msg -> error msg return (Map.fromList - $ map (\(file, gpd) -> ((gpdPackageName gpd),(file, gpd))) unique + $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique , map fst dupIgnored) -makeRel :: (MonadIO m) => Path Abs File -> m FilePath -makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath +formatGroup :: [Path Rel File] -> String +formatGroup = concatMap formatPath + where formatPath path = "- " <> toFilePath path <> "\n" -formatGroup :: [String] -> String -formatGroup = concat . (map formatPath) - where formatPath path = "- " <> path <> "\n" - -reportMissingCabalFiles - :: (MonadIO m, MonadLogger m) => [Path Abs File] -> Bool -> m () +reportMissingCabalFiles :: (MonadIO m, MonadThrow m, MonadLogger m) + => [Path Abs File] -- ^ Directories to scan + -> Bool -- ^ Whether to scan sub-directories + -> m () reportMissingCabalFiles cabalfps includeSubdirs = do - allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir + allCabalfps <- findCabalFiles includeSubdirs =<< getCurrentDir - relpaths <- mapM makeRel (allCabalfps \\ cabalfps) - when (not (null relpaths)) $ do + relpaths <- mapM makeRelativeToCurrentDir (allCabalfps \\ cabalfps) + unless (null relpaths) $ do $logWarn $ "The following packages are missing from the config:" $logWarn $ T.pack (formatGroup relpaths) @@ -601,7 +597,7 @@ solveExtraDeps modStackYaml = do bconfig <- asks getBuildConfig let stackYaml = bcStackYaml bconfig - relStackYaml <- makeRel stackYaml + relStackYaml <- toFilePath <$> makeRelativeToCurrentDir stackYaml $logInfo $ "Using configuration file: " <> T.pack relStackYaml let cabalDirs = Map.keys $ envConfigPackages econfig diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 87fb5a874a..f32918a6d1 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -39,7 +39,7 @@ upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpMan -> Maybe String -- ^ git hash at time of building, if known -> m () upgrade gitRepo mresolver builtHash = - withCanonicalizedSystemTempDirectory "stack-upgrade" $ \tmp -> do + withSystemTempDir "stack-upgrade" $ \tmp -> do menv <- getMinimalEnvOverride mdir <- case gitRepo of Just repo -> do diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 080143e380..dba43679b5 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -62,10 +62,10 @@ import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable) import Distribution.System (OS (Windows), Platform (Platform)) -import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) -import Path.IO (createTree, parseRelAsAbsFile) +import Path +import Path.IO hiding (findExecutable) import Prelude -- Fix AMP warning -import System.Directory (doesFileExist, getCurrentDirectory) +import qualified System.Directory as D import System.Environment (getEnvironment) import System.Exit import qualified System.FilePath as FP @@ -298,34 +298,29 @@ sinkProcessStderrStdoutHandle wd menv name args err out = do -- | Perform pre-call-process tasks. Ensure the working directory exists and find the -- executable path. preProcess :: (MonadIO m) - => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary - -> EnvOverride - -> String -- ^ Command name - -> m FilePath + => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary + -> EnvOverride -- ^ How to override environment + -> String -- ^ Command name + -> m FilePath preProcess wd menv name = do name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name - maybe (return ()) createTree wd + maybe (return ()) ensureDir wd return name' -- | Check if the given executable exists on the given PATH. -doesExecutableExist :: MonadIO m => EnvOverride -> String -> m Bool +doesExecutableExist :: (MonadIO m) + => EnvOverride -- ^ How to override environment + -> String -- ^ Name of executable + -> m Bool doesExecutableExist menv name = liftM isJust $ findExecutable menv name --- | Turn a relative path into an absolute path. --- --- Note: this function duplicates the functionality of makeAbsolute --- in recent versions of "System.Directory", and can be removed once --- we no longer need to support older versions of GHC. -makeAbsolute :: FilePath -> IO FilePath -makeAbsolute = fmap FP.normalise . absolutize - where absolutize path - | FP.isRelative path = fmap (FP. path) getCurrentDirectory - | otherwise = return path - -- | Find the complete path for the executable. -- -- Throws a 'ReadProcessException' if unsuccessful. -findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File)) +findExecutable :: (MonadIO m, MonadThrow n) + => EnvOverride -- ^ How to override environment + -> String -- ^ Name of executable + -> m (n (Path Abs File)) -- ^ Full path to that executable on success findExecutable eo name0 | any FP.isPathSeparator name0 = do let names0 | null (eoExeExtension eo) = [name0] @@ -333,10 +328,10 @@ findExecutable eo name0 | any FP.isPathSeparator name0 = do | otherwise = [name0 ++ eoExeExtension eo, name0] testNames [] = return $ throwM $ ExecutableNotFoundAt name0 testNames (name:names) = do - exists <- liftIO $ doesFileExist name + exists <- liftIO $ D.doesFileExist name if exists then do - path <- liftIO $ parseRelAsAbsFile name + path <- liftIO $ resolveFile' name return $ return path else testNames names testNames names0 @@ -354,10 +349,10 @@ findExecutable eo name = liftIO $ do | otherwise = [fp0 ++ eoExeExtension eo, fp0] testFPs [] = loop dirs testFPs (fp:fps) = do - exists <- doesFileExist fp + exists <- D.doesFileExist fp if exists then do - fp' <- makeAbsolute fp >>= parseAbsFile + fp' <- D.makeAbsolute fp >>= parseAbsFile return $ return fp' else testFPs fps testFPs fps0 diff --git a/src/main/Main.hs b/src/main/Main.hs index 56e9987ce5..27e745b531 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -86,8 +86,7 @@ import Stack.Types.Internal import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload -import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) -import qualified System.Directory as Directory (findExecutable) +import qualified System.Directory as D import System.Environment (getEnvironment, getProgName, getArgs, withArgs) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) @@ -437,7 +436,6 @@ commandLineHandler progName isInterpreter = complicatedOptions addSubCommands' cmd title = addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts) - globalOpts kind = extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*> extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*> @@ -460,7 +458,7 @@ secondaryCommandHandler args f = if elem pathSeparator cmd then return f else do - mExternalExec <- Directory.findExecutable cmd + mExternalExec <- D.findExecutable cmd case mExternalExec of Just ex -> do menv <- getEnvOverride buildPlatform @@ -483,7 +481,7 @@ interpreterHandler -> ParserFailure ParserHelp -> IO (GlobalOptsMonoid, (GlobalOpts -> IO (), t)) interpreterHandler args f = do - isFile <- doesFileExist file + isFile <- D.doesFileExist file if isFile then runInterpreterCommand file else parseResultHandler (errorCombine (noSuchFile file)) @@ -762,7 +760,7 @@ withUserFileLock go@GlobalOpts{} dir act = do then do let lockfile = $(mkRelFile "lockfile") let pth = dir lockfile - liftIO $ createDirectoryIfMissing True (toFilePath dir) + ensureDir dir -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) @@ -923,8 +921,8 @@ uploadCmd (args, mpvpBounds, ignoreCheck, shouldSign) go = do r <- f x (as, bs) <- partitionM f xs return $ if r then (x:as, bs) else (as, x:bs) - (files, nonFiles) <- partitionM doesFileExist args - (dirs, invalid) <- partitionM doesDirectoryExist nonFiles + (files, nonFiles) <- partitionM D.doesFileExist args + (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles unless (null invalid) $ error $ "stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ show invalid @@ -940,11 +938,11 @@ uploadCmd (args, mpvpBounds, ignoreCheck, shouldSign) go = do withBuildConfigAndLock go $ \_ -> do uploader <- getUploader unless ignoreCheck $ - mapM_ (parseRelAsAbsFile >=> checkSDistTarball) files + mapM_ (resolveFile' >=> checkSDistTarball) files forM_ files (\file -> - do tarFile <- parseRelAsAbsFile file + do tarFile <- resolveFile' file liftIO (Upload.upload uploader (toFilePath tarFile)) when @@ -955,7 +953,7 @@ uploadCmd (args, mpvpBounds, ignoreCheck, shouldSign) go = do tarFile)) unless (null dirs) $ forM_ dirs $ \dir -> do - pkgDir <- parseRelAsAbsDir dir + pkgDir <- resolveDir' dir (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir unless ignoreCheck $ checkSDistTarball' tarName tarBytes liftIO $ Upload.uploadBytes uploader tarName tarBytes @@ -974,12 +972,12 @@ sdistCmd (dirs, mpvpBounds, ignoreCheck) go = -- If no directories are specified, build all sdist tarballs. dirs' <- if null dirs then asks (Map.keys . envConfigPackages . getEnvConfig) - else mapM (parseAbsDir <=< liftIO . canonicalizePath) dirs + else mapM resolveDir' dirs forM_ dirs' $ \dir -> do (tarName, tarBytes) <- getSDistTarball mpvpBounds dir distDir <- distDirFromDir dir tarPath <- (distDir ) <$> parseRelFile tarName - liftIO $ createTree $ parent tarPath + ensureDir (parent tarPath) liftIO $ L.writeFile (toFilePath tarPath) tarBytes unless ignoreCheck (checkSDistTarball tarPath) $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) @@ -1075,7 +1073,7 @@ targetsCmd target go@GlobalOpts{..} = withBuildConfig go $ do let bopts = defaultBuildOpts { boptsTargets = [target] } (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts bopts) - pwd <- getWorkingDir + pwd <- getCurrentDir targets <- fmap (concat . snd . unzip) @@ -1137,7 +1135,7 @@ sigSignSdistCmd (url,path) go = withConfigAndLock go (do (manager,lc) <- liftIO (loadConfigWithOpts go) - tarBall <- parseRelAsAbsFile path + tarBall <- resolveFile' path runStackTGlobal manager (lcConfig lc) @@ -1149,7 +1147,7 @@ sigSignSdistCmd (url,path) go = loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO)) loadConfigWithOpts go@GlobalOpts{..} = do manager <- newTLSManager - mstackYaml <- forM globalStackYaml parseRelAsAbsFile + mstackYaml <- forM globalStackYaml resolveFile' lc <- runStackLoggingTGlobal manager go $ do lc <- loadConfig globalConfigMonoid mstackYaml globalResolver -- If we have been relaunched in a Docker container, perform in-container initialization @@ -1175,7 +1173,7 @@ withMiniConfigAndLock go inner = -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = do - pwd <- getWorkingDir + pwd <- getCurrentDir withMiniConfigAndLock go (initProject pwd initOpts (globalResolver go)) -- | Create a project directory structure and initialize the stack config. diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs index a300a2efd3..0540b8d04f 100644 --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -10,14 +10,11 @@ import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path import Path.IO -import System.Directory import Test.Hspec hiding (shouldNotBe, shouldNotReturn) - -- TODO: share across test files -withTempDir :: (Path Abs Dir -> IO a) -> IO a -withTempDir = withCanonicalizedSystemTempDirectory "NHD_VerifiedSpec" - +withTempDir' :: (Path Abs Dir -> IO a) -> IO a +withTempDir' = withSystemTempDir "NHD_VerifiedSpec" -- | An example path to download the exampleReq. getExamplePath :: Path Abs Dir -> IO (Path Abs File) @@ -96,59 +93,54 @@ spec = beforeAll setup $ afterAll teardown $ do -- Preconditions: -- * the exampleReq server is running -- * the test runner has working internet access to it - it "downloads the file correctly" $ \T{..} -> withTempDir $ \dir -> do + it "downloads the file correctly" $ \T{..} -> withTempDir' $ \dir -> do examplePath <- getExamplePath dir - let exampleFilePath = toFilePath examplePath - doesFileExist exampleFilePath `shouldReturn` False + doesFileExist examplePath `shouldReturn` False let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True - doesFileExist exampleFilePath `shouldReturn` True + doesFileExist examplePath `shouldReturn` True - it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir $ \dir -> do + it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir' $ \dir -> do examplePath <- getExamplePath dir - let exampleFilePath = toFilePath examplePath - doesFileExist exampleFilePath `shouldReturn` False + doesFileExist examplePath `shouldReturn` False let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True - doesFileExist exampleFilePath `shouldReturn` True + doesFileExist examplePath `shouldReturn` True go `shouldReturn` False - doesFileExist exampleFilePath `shouldReturn` True + doesFileExist examplePath `shouldReturn` True -- https://github.com/commercialhaskell/stack/issues/372 - it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir $ \dir -> do + it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir' $ \dir -> do examplePath <- getExamplePath dir let exampleFilePath = toFilePath examplePath writeFile exampleFilePath exampleWrongContent - doesFileExist exampleFilePath `shouldReturn` True + doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldReturn` exampleWrongContent let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True - doesFileExist exampleFilePath `shouldReturn` True + doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldNotReturn` exampleWrongContent - it "rejects incorrect content length" $ \T{..} -> withTempDir $ \dir -> do + it "rejects incorrect content length" $ \T{..} -> withTempDir' $ \dir -> do examplePath <- getExamplePath dir - let exampleFilePath = toFilePath examplePath let wrongContentLengthReq = exampleReq { drLengthCheck = Just exampleWrongContentLength } let go = runWith manager $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook go `shouldThrow` isWrongContentLength - doesFileExist exampleFilePath `shouldReturn` False + doesFileExist examplePath `shouldReturn` False - it "rejects incorrect digest" $ \T{..} -> withTempDir $ \dir -> do + it "rejects incorrect digest" $ \T{..} -> withTempDir' $ \dir -> do examplePath <- getExamplePath dir - let exampleFilePath = toFilePath examplePath let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest } let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] } let go = runWith manager $ verifiedDownload wrongDigestReq examplePath exampleProgressHook go `shouldThrow` isWrongDigest - doesFileExist exampleFilePath `shouldReturn` False + doesFileExist examplePath `shouldReturn` False -- https://github.com/commercialhaskell/stack/issues/240 - it "can download hackage tarballs" $ \T{..} -> withTempDir $ \dir -> do + it "can download hackage tarballs" $ \T{..} -> withTempDir' $ \dir -> do dest <- fmap (dir ) $ parseRelFile "acme-missiles-0.3.tar.gz" - let destFp = toFilePath dest req <- parseUrl "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz" let dReq = DownloadRequest { drRequest = req @@ -157,6 +149,6 @@ spec = beforeAll setup $ afterAll teardown $ do , drRetryPolicy = limitRetries 1 } let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook - doesFileExist destFp `shouldReturn` False + doesFileExist dest `shouldReturn` False go `shouldReturn` True - doesFileExist destFp `shouldReturn` True + doesFileExist dest `shouldReturn` True diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index 24fa413ff1..1faad31102 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -60,7 +60,6 @@ spec = beforeAll setup $ afterAll teardown $ do let resetVar = setEnv name originalValue bracket_ setVar resetVar action - describe "loadConfig" $ do let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing Nothing) let loadBuildConfigRest m = runStackLoggingT m logLevel False False @@ -86,7 +85,7 @@ spec = beforeAll setup $ afterAll teardown $ do bcRoot bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do - withCanonicalizedSystemTempDirectory "config-is-here" $ \dir -> do + withSystemTempDir "config-is-here" $ \dir -> do let stackYamlFp = toFilePath (dir stackDotYaml) writeFile stackYamlFp sampleConfig withEnvVar "STACK_YAML" stackYamlFp $ do diff --git a/stack-7.8.yaml b/stack-7.8.yaml index eced02f18a..a0ce9e96cb 100644 --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -1,6 +1,8 @@ resolver: lts-2.22 extra-deps: -- path-0.5.2 +- path-0.5.3 +- path-io-0.3.1 +- directory-1.2.2.0 - Win32-notify-0.3.0.1 - hfsevents-0.1.5 - project-template-0.2.0 diff --git a/stack.cabal b/stack.cabal index f5b9fa897b..d2c57e85dc 100644 --- a/stack.cabal +++ b/stack.cabal @@ -122,7 +122,6 @@ library Data.Attoparsec.Args Data.Attoparsec.Interpreter Data.Maybe.Extra - Path.IO Path.Extra other-modules: Network.HTTP.Download Control.Concurrent.Execute @@ -180,6 +179,7 @@ library , old-locale >= 1.0.0.6 , optparse-applicative >= 0.11 && < 0.13 , path >= 0.5.1 + , path-io >= 0.3.1 , persistent >= 2.1.2 , persistent-sqlite >= 2.1.4 , persistent-template >= 2.1.1 @@ -244,6 +244,7 @@ executable stack , old-locale >= 1.0.0.6 , optparse-applicative >= 0.11.0.2 && < 0.13 , path + , path-io >= 0.3.1 , process , resourcet >= 1.1.4.1 , stack @@ -288,6 +289,7 @@ test-suite stack-test , exceptions , filepath , path + , path-io >= 0.3.1 , temporary , stack , monad-logger diff --git a/stack.yaml b/stack.yaml index 97cd290990..e804d2be53 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,4 +9,5 @@ nix: enable: false packages: - zlib -extra-deps: [] +extra-deps: +- path-io-0.3.1