{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Prelude.File (
mergeFileTree,
copyFileE,
findFilesDeep,
getDirectoryContentsRecursive,
getDirectoryContentsRecursiveBFS,
getDirectoryContentsRecursiveDFS,
getDirectoryContentsRecursiveUnsafe,
getDirectoryContentsRecursiveBFSUnsafe,
getDirectoryContentsRecursiveDFSUnsafe,
recordedInstallationFile,
module GHCup.Prelude.File.Search,
chmod_755,
isBrokenSymlink,
copyFile,
deleteFile,
install,
removeEmptyDirectory,
removeDirIfEmptyOrIsSymlink,
removeEmptyDirsRecursive,
rmFileForce,
createDirRecursive',
recyclePathForcibly,
rmDirectory,
recycleFile,
rmFile,
rmDirectoryLink,
moveFilePortable,
moveFile,
rmPathForcibly,
exeExt,
exeExt',
getLinkTarget,
pathIsLink,
rmLink,
createLink
) where
import GHCup.Utils.Dirs
import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
import GHCup.Prelude.Internal
import GHCup.Prelude.File.Search
#if IS_WINDOWS
import GHCup.Prelude.File.Windows
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.File.Posix
import GHCup.Prelude.Posix
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import Text.Regex.Posix
import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Control.Exception.Safe
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Haskus.Utils.Variant.Excepts
import System.FilePath
import Text.PrettyPrint.HughesPJClass (prettyShow)
import qualified Data.Text as T
import qualified Streamly.Prelude as S
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import GHC.IO.Exception
import System.IO.Error
mergeFileTree :: ( MonadMask m
, S.MonadAsync m
, MonadReader env m
, HasDirs env
, HasLog env
, MonadCatch m
)
=> GHCupPath
-> InstallDirResolved
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ())
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree :: forall (m :: * -> *) env.
(MonadMask m, MonadAsync m, MonadReader env m, HasDirs env,
HasLog env, MonadCatch m) =>
GHCupPath
-> InstallDirResolved
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ())
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree GHCupPath
_ (GHCupBinDir FilePath
fp) Tool
_ GHCTargetVersion
_ FilePath -> FilePath -> m ()
_ =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: internal error, called on " forall a. Semigroup a => a -> a -> a
<> FilePath
fp)
mergeFileTree GHCupPath
sourceBase InstallDirResolved
destBase Tool
tool GHCTargetVersion
v' FilePath -> FilePath -> m ()
copyOp = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Merging file tree from \""
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase)
forall a. Semigroup a => a -> a -> a
<> Text
"\" to \""
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
forall a. Semigroup a => a -> a -> a
<> Text
"\""
FilePath
recFile <- forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
tool GHCTargetVersion
v'
Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
baseCheck (GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *}. MonadThrow f => FilePath -> f ()
destCheck (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
recFile)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: DB file " forall a. Semigroup a => a -> a -> a
<> FilePath
recFile forall a. Semigroup a => a -> a -> a
<> FilePath
" already exists!")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
recFile)
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ (FilePath -> m ()
cleanupOnPartialInstall FilePath
recFile) forall a b. (a -> b) -> a -> b
$ Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts forall a b. (a -> b) -> a -> b
$ do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Starting merge"
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SerialT m a -> m ()
S.mapM_ (forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursive GHCupPath
sourceBase) forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
FilePath -> m ()
copy FilePath
f
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
"Recording installed file: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f
FilePath -> FilePath -> m ()
recordInstalledFile FilePath
f FilePath
recFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
f
where
wrapInExcepts :: Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts = forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall a b. (a -> b) -> a -> b
$ IOException -> FilePath -> FilePath -> MergeFileTreeError
MergeFileTreeError IOException
e (GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase) (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase))
cleanupOnPartialInstall :: FilePath -> m ()
cleanupOnPartialInstall FilePath
recFile = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) forall a b. (a -> b) -> a -> b
$ do
(forall a. NFData a => a -> a
force -> ![FilePath]
l) <- forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(FilePath -> IO FilePath
readFile FilePath
recFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate)
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Deleting recorded files due to partial install"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
l forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
let dest :: FilePath
dest = InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropDrive FilePath
f
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
dest
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
recFile
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
recFile
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
UnsatisfiedConstraints forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadCatch m) =>
FilePath -> m ()
removeEmptyDirsRecursive (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
recordInstalledFile :: FilePath -> FilePath -> m ()
recordInstalledFile FilePath
f FilePath
recFile = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
appendFile FilePath
recFile (FilePath
f forall a. Semigroup a => a -> a -> a
<> FilePath
"\n")
copy :: FilePath -> m ()
copy FilePath
source = do
let dest :: FilePath
dest = InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase FilePath -> FilePath -> FilePath
</> FilePath
source
src :: FilePath
src = GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase FilePath -> FilePath -> FilePath
</> FilePath
source
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isAbsolute FilePath
source)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source file " forall a. Semigroup a => a -> a -> a
<> FilePath
source forall a. Semigroup a => a -> a -> a
<> FilePath
" is not relative!")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory forall a b. (a -> b) -> a -> b
$ FilePath
dest
FilePath -> FilePath -> m ()
copyOp FilePath
src FilePath
dest
baseCheck :: FilePath -> IO ()
baseCheck FilePath
src = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isRelative FilePath
src)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source base directory " forall a. Semigroup a => a -> a -> a
<> FilePath
src forall a. Semigroup a => a -> a -> a
<> FilePath
" is not absolute!")
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesDirectoryExist FilePath
src)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source base directory " forall a. Semigroup a => a -> a -> a
<> FilePath
src forall a. Semigroup a => a -> a -> a
<> FilePath
" does not exist!")
destCheck :: FilePath -> f ()
destCheck FilePath
dest = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isRelative FilePath
dest)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: destination base directory " forall a. Semigroup a => a -> a -> a
<> FilePath
dest forall a. Semigroup a => a -> a -> a
<> FilePath
" is not absolute!")
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE :: forall (xs :: [*]) (m :: * -> *).
(CopyError :< xs, MonadCatch m, MonadIO m) =>
FilePath -> FilePath -> Bool -> Excepts xs m ()
copyFileE FilePath
from FilePath
to = forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CopyError
CopyError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool -> IO ()
copyFile FilePath
from FilePath
to
getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveDFS :: forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursiveDFS (GHCupPath -> FilePath
fromGHCupPath -> FilePath
fp) = forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadAsync m) =>
FilePath -> SerialT m FilePath
getDirectoryContentsRecursiveDFSUnsafe FilePath
fp
getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveBFS :: forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursiveBFS (GHCupPath -> FilePath
fromGHCupPath -> FilePath
fp) = forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadAsync m) =>
FilePath -> SerialT m FilePath
getDirectoryContentsRecursiveBFSUnsafe FilePath
fp
getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> GHCupPath
-> S.SerialT m FilePath
getDirectoryContentsRecursive :: forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursive = forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursiveBFS
getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
=> FilePath
-> S.SerialT m FilePath
getDirectoryContentsRecursiveUnsafe :: forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
FilePath -> SerialT m FilePath
getDirectoryContentsRecursiveUnsafe = forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadAsync m) =>
FilePath -> SerialT m FilePath
getDirectoryContentsRecursiveBFSUnsafe
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
findFilesDeep GHCupPath
path Regex
regex =
forall (m :: * -> *) a. Monad m => SerialT m a -> m [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> Bool) -> t m a -> t m a
S.filter (forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursive GHCupPath
path
recordedInstallationFile :: ( MonadReader env m
, HasDirs env
)
=> Tool
-> GHCTargetVersion
-> m FilePath
recordedInstallationFile :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
t GHCTargetVersion
v' = do
Dirs {FilePath
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dbDir FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow Tool
t FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack (GHCTargetVersion -> Text
tVerToText GHCTargetVersion
v'))
removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink :: forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadCatch m) =>
FilePath -> m ()
removeDirIfEmptyOrIsSymlink FilePath
filepath =
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
UnsatisfiedConstraints forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InappropriateType
(forall {m :: * -> *}.
(MonadIO m, MonadMask m) =>
FilePath -> IOException -> m ()
handleIfSym FilePath
filepath)
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeEmptyDirectory FilePath
filepath)
where
handleIfSym :: FilePath -> IOException -> m ()
handleIfSym FilePath
fp IOException
e = do
Bool
isSym <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
pathIsSymbolicLink FilePath
fp
if Bool
isSym
then forall (m :: * -> *). (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce FilePath
fp
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IOException -> IO a
ioError IOException
e
removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive :: forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadCatch m) =>
FilePath -> m ()
removeEmptyDirsRecursive = forall {m :: * -> *}. MonadIO m => FilePath -> m ()
go
where
go :: FilePath -> m ()
go FilePath
fp = do
[FilePath]
cs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
fp FilePath -> FilePath -> FilePath
</>)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
cs FilePath -> m ()
go
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeEmptyDirectory FilePath
fp
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce :: forall (m :: * -> *). (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce FilePath
filepath = do
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
InappropriateType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
filepath
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' FilePath
p =
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> Bool
isAlreadyExistsError IOException
e then IOException -> IO ()
isSymlinkDir IOException
e else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True
forall a b. (a -> b) -> a -> b
$ FilePath
p
where
isSymlinkDir :: IOException -> IO ()
isSymlinkDir IOException
e = do
Bool
ft <- FilePath -> IO Bool
pathIsSymbolicLink FilePath
p
case Bool
ft of
Bool
True -> do
FilePath
rp <- FilePath -> IO FilePath
canonicalizePath FilePath
p
Bool
rft <- FilePath -> IO Bool
doesDirectoryExist FilePath
rp
case Bool
rft of
Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
Bool
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
recyclePathForcibly :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadMask m
)
=> GHCupPath
-> m ()
recyclePathForcibly :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasDirs env, MonadMask m) =>
GHCupPath -> m ()
recyclePathForcibly GHCupPath
fp
| Bool
isWindows = do
Dirs { GHCupPath
recycleDir :: GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
recycleDir } <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
GHCupPath
tmp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory GHCupPath
recycleDir FilePath
"recyclePathForcibly"
let dest :: GHCupPath
dest = GHCupPath
tmp GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath -> FilePath
takeFileName (GHCupPath -> FilePath
fromGHCupPath GHCupPath
fp)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
moveFile (GHCupPath -> FilePath
fromGHCupPath GHCupPath
fp) (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dest))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
(\IOException
e -> if | IOException -> Bool
isDoesNotExistError IOException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| IOException -> Bool
isPermissionError IOException
e Bool -> Bool -> Bool
|| IOException -> IOErrorType
ioeGetErrorType IOException
e forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation -> forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp)
| Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
tmp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp
rmDirectory :: (MonadIO m, MonadMask m)
=> GHCupPath
-> m ()
rmDirectory :: forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmDirectory GHCupPath
fp
| Bool
isWindows = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removeDirectory GHCupPath
fp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removeDirectory GHCupPath
fp
recycleFile :: ( MonadIO m
, MonadMask m
, MonadReader env m
, HasDirs env
)
=> FilePath
-> m ()
recycleFile :: forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
fp
| Bool
isWindows = do
Dirs { GHCupPath
recycleDir :: GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
recycleDir } <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesDirectoryExist FilePath
fp) forall a b. (a -> b) -> a -> b
$ forall a. IOException -> IO a
ioError (Maybe Handle
-> IOErrorType
-> FilePath
-> FilePath
-> Maybe CInt
-> Maybe FilePath
-> IOException
IOError forall a. Maybe a
Nothing IOErrorType
InappropriateType FilePath
"recycleFile" FilePath
"" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just FilePath
fp))
GHCupPath
tmp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory GHCupPath
recycleDir FilePath
"recycleFile"
let dest :: FilePath
dest = GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmp FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
fp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
moveFile FilePath
fp FilePath
dest)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
(\IOException
e -> if IOException -> Bool
isPermissionError IOException
e Bool -> Bool -> Bool
|| IOException -> IOErrorType
ioeGetErrorType IOException
e forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation then forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
fp) else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
tmp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
fp
rmFile :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
rmFile :: forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
fp
| Bool
isWindows = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
fp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
fp
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
=> FilePath
-> m ()
rmDirectoryLink :: forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
rmDirectoryLink FilePath
fp
| Bool
isWindows = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryLink FilePath
fp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryLink FilePath
fp
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> GHCupPath
-> m ()
rmPathForcibly :: forall (m :: * -> *). (MonadIO m, MonadMask m) => GHCupPath -> m ()
rmPathForcibly GHCupPath
fp
| Bool
isWindows = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp)
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp
exeExt :: String
exeExt :: FilePath
exeExt
| Bool
isWindows = FilePath
".exe"
| Bool
otherwise = FilePath
""
exeExt' :: ByteString
exeExt' :: ByteString
exeExt'
| Bool
isWindows = ByteString
".exe"
| Bool
otherwise = ByteString
""
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
rmLink :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
fp
| Bool
isWindows = do
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile forall a b. (a -> b) -> a -> b
$ FilePath
fp
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath
dropExtension FilePath
fp FilePath -> FilePath -> FilePath
<.> FilePath
"shim")
| Bool
otherwise = forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile forall a b. (a -> b) -> a -> b
$ FilePath
fp
createLink :: ( MonadMask m
, MonadThrow m
, HasLog env
, MonadIO m
, MonadReader env m
, HasDirs env
, MonadUnliftIO m
, MonadFail m
)
=> FilePath
-> FilePath
-> m ()
createLink :: forall (m :: * -> *) env.
(MonadMask m, MonadThrow m, HasLog env, MonadIO m,
MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) =>
FilePath -> FilePath -> m ()
createLink FilePath
link FilePath
exe
| Bool
isWindows = do
Dirs
dirs <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
let shimGen :: FilePath
shimGen = GHCupPath -> FilePath
fromGHCupPath (Dirs -> GHCupPath
cacheDir Dirs
dirs) FilePath -> FilePath -> FilePath
</> FilePath
"gs.exe"
let shim :: FilePath
shim = FilePath -> FilePath
dropExtension FilePath
exe FilePath -> FilePath -> FilePath
<.> FilePath
"shim"
fullLink :: FilePath
fullLink = FilePath -> FilePath
takeDirectory FilePath
exe FilePath -> FilePath -> FilePath
</> FilePath
link
shimContents :: FilePath
shimContents = FilePath
"path = " forall a. Semigroup a => a -> a -> a
<> FilePath
fullLink
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
exe
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"ln -s " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullLink forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Bool -> IO ()
copyFile FilePath
shimGen FilePath
exe Bool
False
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
shim FilePath
shimContents
| Bool
otherwise = do
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"rm -f " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
exe
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Text
"ln -s " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
link forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createFileLink FilePath
link FilePath
exe