{-# 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 ()
_ =
IOException -> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> Excepts '[MergeFileTreeError] m ())
-> IOException -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: internal error, called on " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fp)
mergeFileTree GHCupPath
sourceBase InstallDirResolved
destBase Tool
tool GHCTargetVersion
v' FilePath -> FilePath -> m ()
copyOp = do
m () -> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[MergeFileTreeError] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[MergeFileTreeError] m ())
-> m () -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Merging file tree from \""
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" to \""
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
FilePath
recFile <- Tool
-> GHCTargetVersion -> Excepts '[MergeFileTreeError] m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
Tool -> GHCTargetVersion -> m FilePath
recordedInstallationFile Tool
tool GHCTargetVersion
v'
Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts (Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> Excepts '[MergeFileTreeError] m ()
forall a. IO a -> Excepts '[MergeFileTreeError] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[MergeFileTreeError] m ())
-> IO () -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
baseCheck (GHCupPath -> FilePath
fromGHCupPath GHCupPath
sourceBase)
IO () -> Excepts '[MergeFileTreeError] m ()
forall a. IO a -> Excepts '[MergeFileTreeError] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[MergeFileTreeError] m ())
-> IO () -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall {f :: * -> *}. MonadThrow f => FilePath -> f ()
destCheck (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
Bool
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) (Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ do
Excepts '[MergeFileTreeError] m Bool
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> Excepts '[MergeFileTreeError] m Bool
forall a. IO a -> Excepts '[MergeFileTreeError] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Excepts '[MergeFileTreeError] m Bool)
-> IO Bool -> Excepts '[MergeFileTreeError] m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
recFile)
(Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ IOException -> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> Excepts '[MergeFileTreeError] m ())
-> IOException -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: DB file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
recFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" already exists!")
IO () -> Excepts '[MergeFileTreeError] m ()
forall a. IO a -> Excepts '[MergeFileTreeError] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts '[MergeFileTreeError] m ())
-> IO () -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
recFile)
m ()
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) (es :: [*]) a.
Monad m =>
m () -> Excepts es m a -> Excepts es m a
onE_ (FilePath -> m ()
cleanupOnPartialInstall FilePath
recFile) (Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts (Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Excepts '[MergeFileTreeError] m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug Text
"Starting merge"
m () -> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts '[MergeFileTreeError] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[MergeFileTreeError] m ())
-> m () -> Excepts '[MergeFileTreeError] m ()
forall a b. (a -> b) -> a -> b
$ ((FilePath -> m FilePath) -> SerialT m FilePath -> m ())
-> SerialT m FilePath -> (FilePath -> m FilePath) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> m FilePath) -> SerialT m FilePath -> m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SerialT m a -> m ()
S.mapM_ (GHCupPath -> SerialT m FilePath
forall (m :: * -> *).
(MonadCatch m, MonadAsync m, MonadMask m) =>
GHCupPath -> SerialT m FilePath
getDirectoryContentsRecursive GHCupPath
sourceBase) ((FilePath -> m FilePath) -> m ())
-> (FilePath -> m FilePath) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f -> do
FilePath -> m ()
copy FilePath
f
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
"Recording installed file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f
FilePath -> FilePath -> m ()
recordInstalledFile FilePath
f FilePath
recFile
FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
f
where
wrapInExcepts :: Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
wrapInExcepts = (IOException -> Excepts '[MergeFileTreeError] m ())
-> Excepts '[MergeFileTreeError] m ()
-> Excepts '[MergeFileTreeError] m ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> MergeFileTreeError -> Excepts '[MergeFileTreeError] m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (MergeFileTreeError -> Excepts '[MergeFileTreeError] m ())
-> MergeFileTreeError -> Excepts '[MergeFileTreeError] m ()
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 = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
([FilePath] -> [FilePath]
forall a. NFData a => a -> a
force -> ![FilePath]
l) <- [IOErrorType] -> [FilePath] -> m [FilePath] -> m [FilePath]
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> a -> m a -> m a
hideErrorDef [IOErrorType
NoSuchThing] [] (m [FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> m FilePath -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(FilePath -> IO FilePath
readFile FilePath
recFile IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO FilePath
forall a. a -> IO a
evaluate)
Text -> m ()
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"
[FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
l ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
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
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
dest
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
recFile
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
recFile
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (InstallDirResolved -> FilePath
fromInstallDir InstallDirResolved
destBase)
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
UnsatisfiedConstraints (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
NoSuchThing (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> m ()
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 = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InstallDirResolved -> Bool
isSafeDir InstallDirResolved
destBase) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
appendFile FilePath
recFile (FilePath
f FilePath -> FilePath -> FilePath
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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isAbsolute FilePath
source)
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IOException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> m ()) -> IOException -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
source FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is not relative!")
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (FilePath -> IO ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
dest
FilePath -> FilePath -> m ()
copyOp FilePath
src FilePath
dest
baseCheck :: FilePath -> IO ()
baseCheck FilePath
src = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isRelative FilePath
src)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source base directory " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
src FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is not absolute!")
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesDirectoryExist FilePath
src)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: source base directory " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
src FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" does not exist!")
destCheck :: FilePath -> f ()
destCheck FilePath
dest = do
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isRelative FilePath
dest)
(f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ IOException -> f ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> f ()) -> IOException -> f ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"mergeFileTree: destination base directory " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
dest FilePath -> FilePath -> FilePath
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 = (IOException -> Excepts xs m ())
-> Excepts xs m () -> Excepts xs m ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (CopyError -> Excepts xs m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (CopyError -> Excepts xs m ())
-> (IOException -> CopyError) -> IOException -> Excepts xs m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CopyError
CopyError (FilePath -> CopyError)
-> (IOException -> FilePath) -> IOException -> CopyError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> FilePath
forall a. Show a => a -> FilePath
show) (Excepts xs m () -> Excepts xs m ())
-> (Bool -> Excepts xs m ()) -> Bool -> Excepts xs m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Excepts xs m ()
forall a. IO a -> Excepts xs m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Excepts xs m ())
-> (Bool -> IO ()) -> Bool -> Excepts xs m ()
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) = FilePath -> SerialT m FilePath
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) = FilePath -> SerialT m FilePath
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 = GHCupPath -> SerialT m FilePath
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 = FilePath -> SerialT m FilePath
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 =
SerialT IO FilePath -> IO [FilePath]
forall (m :: * -> *) a. Monad m => SerialT m a -> m [a]
S.toList (SerialT IO FilePath -> IO [FilePath])
-> SerialT IO FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> SerialT IO FilePath -> SerialT IO FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(IsStream t, Monad m) =>
(a -> Bool) -> t m a -> t m a
S.filter (Regex -> FilePath -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex) (SerialT IO FilePath -> SerialT IO FilePath)
-> SerialT IO FilePath -> SerialT IO FilePath
forall a b. (a -> b) -> a -> b
$ GHCupPath -> SerialT IO FilePath
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
baseDir :: GHCupPath
binDir :: FilePath
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
..} <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dbDir FilePath -> FilePath -> FilePath
</> Tool -> 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 =
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
UnsatisfiedConstraints (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IOErrorType -> (IOException -> m ()) -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
InappropriateType
(FilePath -> IOException -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadMask m) =>
FilePath -> IOException -> m ()
handleIfSym FilePath
filepath)
(IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
pathIsSymbolicLink FilePath
fp
if Bool
isSym
then FilePath -> m ()
forall (m :: * -> *). (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce FilePath
fp
else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
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 = FilePath -> m ()
forall {m :: * -> *}. MonadIO m => FilePath -> m ()
go
where
go :: FilePath -> m ()
go FilePath
fp = do
[FilePath]
cs <- IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
fp IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist ([FilePath] -> IO [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
fp FilePath -> FilePath -> FilePath
</>)
[FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
cs FilePath -> m ()
go
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType
(m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
InappropriateType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
filepath
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' :: FilePath -> IO ()
createDirRecursive' FilePath
p =
(IOException -> IO ()) -> IO () -> IO ()
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 IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
(IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True
(FilePath -> IO ()) -> FilePath -> IO ()
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 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
_ -> IOException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
Bool
_ -> IOException -> IO ()
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
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
recycleDir :: GHCupPath
recycleDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
GHCupPath
tmp <- IO GHCupPath -> m GHCupPath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GHCupPath -> m GHCupPath) -> IO GHCupPath -> m GHCupPath
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)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
moveFile (GHCupPath -> FilePath
fromGHCupPath GHCupPath
fp) (GHCupPath -> FilePath
fromGHCupPath GHCupPath
dest))
m () -> (IOException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
(\IOException
e -> if | IOException -> Bool
isDoesNotExistError IOException
e -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| IOException -> Bool
isPermissionError IOException
e Bool -> Bool -> Bool
|| IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation -> m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp)
| Bool
otherwise -> IOException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
tmp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removeDirectory GHCupPath
fp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
recycleDir :: GHCupPath
recycleDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesDirectoryExist FilePath
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall a. IOException -> IO a
ioError (Maybe Handle
-> IOErrorType
-> FilePath
-> FilePath
-> Maybe CInt
-> Maybe FilePath
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InappropriateType FilePath
"recycleFile" FilePath
"" Maybe CInt
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp))
GHCupPath
tmp <- IO GHCupPath -> m GHCupPath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GHCupPath -> m GHCupPath) -> IO GHCupPath -> m GHCupPath
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
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ()
moveFile FilePath
fp FilePath
dest)
m () -> (IOException -> m ()) -> m ()
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 IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
UnsupportedOperation then m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmFile FilePath
fp) else IOException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e)
m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally`
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
tmp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
fp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryLink FilePath
fp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 = m () -> m ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
recover (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly GHCupPath
fp)
| Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> (FilePath -> m ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
fp
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> (FilePath -> m ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath
dropExtension FilePath
fp FilePath -> FilePath -> FilePath
<.> FilePath
"shim")
| Bool
otherwise = IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> (FilePath -> m ()) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile (FilePath -> m ()) -> FilePath -> m ()
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 <- m 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 = " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fullLink
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
FilePath -> m ()
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadIO m, MonadMask m) =>
FilePath -> m ()
rmLink FilePath
exe
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"ln -s " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fullLink Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Bool -> IO ()
copyFile FilePath
shimGen FilePath
exe Bool
False
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
shim FilePath
shimContents
| Bool
otherwise = do
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"rm -f " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
IOErrorType -> m () -> m ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
doesNotExistErrorType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasDirs env) =>
FilePath -> m ()
recycleFile FilePath
exe
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"ln -s " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
link Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
exe
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createFileLink FilePath
link FilePath
exe