hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use strongly types GHCupPath and restrict destructive operations

Browse Source
This commit is contained in:
Julian Ospald
2022-05-13 21:35:34 +02:00
parent fa924eac15
commit c9790e5823
21 changed files with 421 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files

211
lib/GHCup/Utils/Dirs.hs
View File

@@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Utils.Dirs
@@ -30,6 +31,74 @@ module GHCup.Utils.Dirs
, getConfigFilePath
, useXDG
, cleanupTrash
, GHCupPath
, appendGHCupPath
, fromGHCupPath
, createTempGHCupDirectory
, getGHCupTmpDirs
, removeDirectory
, removeDirectoryRecursive
, removePathForcibly
-- System.Directory re-exports
, createDirectory
, createDirectoryIfMissing
, renameDirectory
, listDirectory
, getDirectoryContents
, getCurrentDirectory
, setCurrentDirectory
, withCurrentDirectory
, getHomeDirectory
, XdgDirectory(..)
, getXdgDirectory
, XdgDirectoryList(..)
, getXdgDirectoryList
, getAppUserDataDirectory
, getUserDocumentsDirectory
, getTemporaryDirectory
, removeFile
, renameFile
, renamePath
, getFileSize
, canonicalizePath
, makeAbsolute
, makeRelativeToCurrentDirectory
, doesPathExist
, doesFileExist
, doesDirectoryExist
, findExecutable
, findExecutables
, findExecutablesInDirectories
, findFile
, findFileWith
, findFilesWith
, exeExtension
, createFileLink
, createDirectoryLink
, removeDirectoryLink
, pathIsSymbolicLink
, getSymbolicLinkTarget
, Permissions
, emptyPermissions
, readable
, writable
, executable
, searchable
, setOwnerReadable
, setOwnerWritable
, setOwnerExecutable
, setOwnerSearchable
, getPermissions
, setPermissions
, copyPermissions
, getAccessTime
, getModificationTime
, setAccessTime
, setModificationTime
, isSymbolicLink
)
where
@@ -41,23 +110,35 @@ import GHCup.Types.Optics
import GHCup.Utils.MegaParsec
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.File.Common
import GHCup.Utils.String.QQ
import Control.DeepSeq (NFData, rnf)
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.List
import Data.ByteString ( ByteString )
import Data.Bifunctor
import Data.Maybe
import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
import System.Directory
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import qualified System.Directory as SD
import System.DiskSpace
import System.Environment
import System.FilePath
import System.IO.Temp
import Text.Regex.Posix
import qualified Data.ByteString as BS
import qualified Data.Text as T
@@ -67,6 +148,41 @@ import Control.Concurrent (threadDelay)
---------------------------
--[ GHCupPath utilities ]--
---------------------------
-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
--
-- The constructor is not exported.
newtype GHCupPath = GHCupPath FilePath
deriving (Show, Eq, Ord)
instance NFData GHCupPath where
rnf (GHCupPath fp) = rnf fp
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)
fromGHCupPath :: GHCupPath -> FilePath
fromGHCupPath (GHCupPath gp) = gp
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d
getGHCupTmpDirs :: IO [GHCupPath]
getGHCupTmpDirs = do
tmpdir <- getCanonicalTemporaryDirectory
ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
tmpdir
(makeRegexOpts compExtended
execBlank
([s|^ghcup-.*$|] :: ByteString)
)
pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (("ghcup-" `isPrefixOf`) . takeDirectory) $ ghcup_dirs)
------------------------------
--[ GHCup base directories ]--
------------------------------
@@ -76,11 +192,11 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
ghcupBaseDir :: IO GHCupPath
ghcupBaseDir
| isWindows = do
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
| otherwise = do
xdg <- useXDG
if xdg
@@ -90,19 +206,19 @@ ghcupBaseDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
pure (GHCupPath (bdir </> ".ghcup"))
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO FilePath
ghcupConfigDir :: IO GHCupPath
ghcupConfigDir
| isWindows = ghcupBaseDir
| otherwise = do
@@ -114,12 +230,12 @@ ghcupConfigDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
pure (GHCupPath (bdir </> ".ghcup"))
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -127,7 +243,7 @@ ghcupConfigDir
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO FilePath
ghcupBinDir
| isWindows = ghcupBaseDir <&> (</> "bin")
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
| otherwise = do
xdg <- useXDG
if xdg
@@ -137,16 +253,16 @@ ghcupBinDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO FilePath
ghcupCacheDir :: IO GHCupPath
ghcupCacheDir
| isWindows = ghcupBaseDir <&> (</> "cache")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
| otherwise = do
xdg <- useXDG
if xdg
@@ -156,17 +272,17 @@ ghcupCacheDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
pure (GHCupPath (bdir </> "ghcup"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO FilePath
ghcupLogsDir :: IO GHCupPath
ghcupLogsDir
| isWindows = ghcupBaseDir <&> (</> "logs")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
| otherwise = do
xdg <- useXDG
if xdg
@@ -176,17 +292,17 @@ ghcupLogsDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
pure (GHCupPath (bdir </> "ghcup" </> "logs"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
-- | Defaults to '~/.ghcup/db.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO FilePath
ghcupDbDir :: IO GHCupPath
ghcupDbDir
| isWindows = ghcupBaseDir <&> (</> "db")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
| otherwise = do
xdg <- useXDG
if xdg
@@ -196,14 +312,14 @@ ghcupDbDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "db")
else ghcupBaseDir <&> (</> "db")
pure (GHCupPath (bdir </> "ghcup" </> "db"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
ghcupRecycleDir :: IO GHCupPath
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
@@ -227,7 +343,7 @@ getAllDirs = do
getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath = do
confDir <- liftIO ghcupConfigDir
pure $ confDir </> "config.yaml"
pure $ fromGHCupPath confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
@@ -245,10 +361,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
ghcupGHCBaseDir = do
Dirs {..} <- getDirs
pure (baseDir </> "ghc")
pure (baseDir `appendGHCupPath` "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -257,11 +373,11 @@ ghcupGHCBaseDir = do
-- * 8.8.4
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
-> m GHCupPath
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir </> verdir)
pure (ghcbasedir `appendGHCupPath` verdir)
-- | See 'ghcupToolParser'.
@@ -274,19 +390,19 @@ parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp
-- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
ghcupHLSBaseDir = do
Dirs {..} <- getDirs
pure (baseDir </> "hls")
pure (baseDir `appendGHCupPath` "hls")
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> Version
-> m FilePath
-> m GHCupPath
ghcupHLSDir ver = do
basedir <- ghcupHLSBaseDir
let verdir = T.unpack $ prettyVer ver
pure (basedir </> verdir)
pure (basedir `appendGHCupPath` verdir)
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
@@ -296,8 +412,8 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> m FilePath
mkGhcupTmpDir = do
=> m GHCupPath
mkGhcupTmpDir = GHCupPath <$> do
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
@@ -333,14 +449,14 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> m FilePath
=> m GHCupPath
withGHCupTmpDir = snd <$> withRunInIO (\run ->
run
$ allocate
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly
$ fp))
@@ -381,12 +497,27 @@ cleanupTrash :: ( MonadIO m
=> m ()
cleanupTrash = do
Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory recycleDir
contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
if null contents
then pure ()
else do
logWarn ("Removing leftover files in " <> T.pack recycleDir)
logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir))
forM_ contents (\fp -> handleIO (\e ->
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp))
) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp))
-- System.Directory re-exports with GHCupPath
removeDirectory :: GHCupPath -> IO ()
removeDirectory (GHCupPath fp) = SD.removeDirectory fp
removeDirectoryRecursive :: GHCupPath -> IO ()
removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp
removePathForcibly :: GHCupPath -> IO ()
removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp

37
lib/GHCup/Utils/Dirs.hs-boot Normal file
View File

@@ -0,0 +1,37 @@
module GHCup.Utils.Dirs
( GHCupPath
, appendGHCupPath
, fromGHCupPath
, createTempGHCupDirectory
, removeDirectory
, removeDirectoryRecursive
, removePathForcibly
)
where
import Control.DeepSeq (NFData)
-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
newtype GHCupPath = GHCupPath FilePath
instance Show GHCupPath where
instance Eq GHCupPath where
instance Ord GHCupPath where
instance NFData GHCupPath where
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
fromGHCupPath :: GHCupPath -> FilePath
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
removeDirectory :: GHCupPath -> IO ()
removeDirectoryRecursive :: GHCupPath -> IO ()
removePathForcibly :: GHCupPath -> IO ()

12
lib/GHCup/Utils/File.hs
View File

@@ -19,6 +19,7 @@ module GHCup.Utils.File (
#endif
) where
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
@@ -32,7 +33,6 @@ import GHC.IO ( evaluate )
import Control.Exception.Safe
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
import System.Directory hiding (findFiles, copyFile)
import System.FilePath
import Data.List (nub)
@@ -42,9 +42,9 @@ import Control.DeepSeq (force)
-- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively.
mergeFileTreeAll :: MonadIO m
=> FilePath -- ^ source base directory from which to install findFiles
=> GHCupPath -- ^ source base directory from which to install findFiles
-> FilePath -- ^ destination base dir
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m [FilePath]
mergeFileTreeAll sourceBase destBase copyOp = do
(force -> !sourceFiles) <- liftIO
@@ -54,12 +54,12 @@ mergeFileTreeAll sourceBase destBase copyOp = do
mergeFileTree :: MonadIO m
=> FilePath -- ^ source base directory from which to install findFiles
=> GHCupPath -- ^ source base directory from which to install findFiles
-> [FilePath] -- ^ relative filepaths from source base directory
-> FilePath -- ^ destination base dir
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m ()
mergeFileTree sourceBase sources destBase copyOp = do
mergeFileTree (fromGHCupPath -> sourceBase) sources destBase copyOp = do
-- These checks are not atomic, but we perform them to have
-- the opportunity to abort before copying has started.
--

9
lib/GHCup/Utils/File/Common.hs
View File

@@ -9,6 +9,7 @@ module GHCup.Utils.File.Common (
) where
import GHCup.Utils.Prelude
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
import GHCup.Types(ProcessError(..), CapturedProcess(..))
import Control.Monad.Reader
@@ -16,7 +17,11 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Void
import GHC.IO.Exception
import System.Directory hiding (findFiles, copyFile)
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import System.FilePath
import Text.Regex.Posix
@@ -94,7 +99,7 @@ findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
findFilesDeep :: FilePath -> Regex -> IO [FilePath]
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
findFilesDeep path regex = do
contents <- getDirectoryContentsRecursive path
pure $ filter (match regex) contents

8
lib/GHCup/Utils/File/Posix.hs
View File

@@ -17,6 +17,7 @@ Some of these functions use sophisticated logging.
-}
module GHCup.Utils.File.Posix where
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
@@ -42,7 +43,6 @@ import GHC.IO.Exception
import System.IO ( stderr, hClose, hSetBinaryMode )
import System.IO.Error
import System.FilePath
import System.Directory hiding ( copyFile )
import System.Posix.Directory
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
import System.Posix.Internals ( withFilePath )
@@ -56,6 +56,7 @@ import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Directory as PD
import qualified System.Posix.Files as PF
import qualified System.Posix.Process as SPP
import qualified System.Posix.IO as SPI
@@ -101,7 +102,7 @@ execLogged exe args chdir lfile env = do
Settings {..} <- getSettings
Dirs {..} <- getDirs
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
let logfile = logsDir </> lfile <> ".log"
let logfile = fromGHCupPath logsDir </> lfile <> ".log"
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
closeFd
(action verbose noColor)
@@ -550,3 +551,6 @@ install from to fail' = do
| PF.isSymbolicLink fs = recreateSymlink from to fail'
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
removeEmptyDirectory :: FilePath -> IO ()
removeEmptyDirectory = PD.removeDirectory

6
lib/GHCup/Utils/File/Windows.hs
View File

@@ -17,7 +17,7 @@ Some of these functions use sophisticated logging.
module GHCup.Utils.File.Windows where
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs
import GHCup.Utils.Dirs hiding ( copyFile )
import GHCup.Utils.File.Common
import GHCup.Utils.Logger
import GHCup.Types
@@ -32,7 +32,6 @@ import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory hiding ( copyFile )
import System.Environment
import System.FilePath
import System.IO
@@ -284,3 +283,6 @@ deleteFile = WS.deleteFile
install :: FilePath -> FilePath -> Bool -> IO ()
install = copyFile
removeEmptyDirectory :: FilePath -> IO ()
removeEmptyDirectory = WS.removeDirectory

7
lib/GHCup/Utils/Logger.hs
View File

@@ -17,6 +17,7 @@ module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
import GHCup.Utils.String.QQ
@@ -117,14 +118,14 @@ initGHCupFileLogging :: ( MonadReader env m
) => m FilePath
initGHCupFileLogging = do
Dirs { logsDir } <- getDirs
let logfile = logsDir </> "ghcup.log"
let logfile = fromGHCupPath logsDir </> "ghcup.log"
logFiles <- liftIO $ findFiles
logsDir
(fromGHCupPath logsDir)
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
liftIO $ writeFile logfile ""
pure logfile

61
lib/GHCup/Utils/Prelude.hs
View File

@@ -27,6 +27,7 @@ module GHCup.Utils.Prelude
)
where
import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
import GHCup.Types
import GHCup.Errors
import GHCup.Types.Optics
@@ -44,9 +45,8 @@ import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
import Data.Maybe
import Data.Foldable
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.String
import Data.Text ( Text )
@@ -56,9 +56,12 @@ import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import System.IO.Error
import System.IO.Temp
import System.IO.Unsafe
import System.Directory hiding ( copyFile )
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, copyFile
)
import System.FilePath
import Control.Retry
@@ -397,30 +400,6 @@ createDirRecursive' p =
_ -> throwIO e
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map takeDirectory $ fmap snd srcFiles
traverse_ (createDirectoryIfMissing True) dirs
-- Copy all the files
sequence_ [ let src = srcBase </> srcFile
dest = targetDir </> srcFile
in doCopy src dest
| (srcBase, srcFile) <- srcFiles ]
-- | List all the files in a directory and all subdirectories.
--
@@ -429,8 +408,12 @@ copyDirectoryRecursive srcDir destDir doCopy = do
-- the source directory structure changes before the list is used.
--
-- TODO: use streamly
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
getDirectoryContentsRecursive :: GHCupPath -> IO [FilePath]
getDirectoryContentsRecursive (fromGHCupPath -> topdir) = getDirectoryContentsRecursiveUnsafe topdir
getDirectoryContentsRecursiveUnsafe :: FilePath -> IO [FilePath]
getDirectoryContentsRecursiveUnsafe topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
@@ -464,14 +447,14 @@ recyclePathForcibly :: ( MonadIO m
, HasDirs env
, MonadMask m
)
=> FilePath
=> GHCupPath
-> m ()
recyclePathForcibly fp
| isWindows = do
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (moveFile fp dest)
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
`catch`
(\e -> if | isDoesNotExistError e -> pure ()
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
@@ -484,7 +467,7 @@ recyclePathForcibly fp
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> FilePath
=> GHCupPath
-> m ()
rmPathForcibly fp
| isWindows = recover (liftIO $ removePathForcibly fp)
@@ -492,7 +475,7 @@ rmPathForcibly fp
rmDirectory :: (MonadIO m, MonadMask m)
=> FilePath
=> GHCupPath
-> m ()
rmDirectory fp
| isWindows = recover (liftIO $ removeDirectory fp)
@@ -512,11 +495,11 @@ recycleFile fp
| isWindows = do
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
let dest = fromGHCupPath tmp </> takeFileName fp
liftIO (moveFile fp dest)
`catch`
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
`finally`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removeFile fp

6
lib/GHCup/Utils/Prelude/Posix.hs
View File

@@ -1,6 +1,10 @@
module GHCup.Utils.Prelude.Posix where
import System.Directory
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import System.Posix.Files