{-# 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


-- | Merge one file tree to another given a copy operation.
--
-- Records every successfully installed file into the destination
-- returned by 'recordedInstallationFile'.
--
-- If any copy operation fails, the record file is deleted, as well
-- as the partially installed files.
mergeFileTree :: ( MonadMask m
                 , S.MonadAsync m
                 , MonadReader env m
                 , HasDirs env
                 , HasLog env
                 , MonadCatch m
                 )
              => GHCupPath                       -- ^ source base directory from which to install findFiles
              -> InstallDirResolved              -- ^ destination base dir
              -> Tool
              -> GHCTargetVersion
              -> (FilePath -> FilePath -> m ())  -- ^ file copy operation
              -> 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
    -- These checks are not atomic, but we perform them to have
    -- the opportunity to abort before copying has started.
    --
    -- The actual copying might still fail.
    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)

    -- we only record for non-isolated installs
    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)

  -- we want the cleanup action to leak through in case of exception
  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


-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
-- depth first
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

-- breadth first
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

-- | More permissive version of 'createDirRecursive'. This doesn't
-- error when the destination is a symlink to a directory.
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


-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
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 {- EXDEV on windows -} -> 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


-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
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 {- EXDEV on windows -} 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


-- | The file extension for executables.
exeExt :: String
exeExt :: FilePath
exeExt
  | Bool
isWindows = FilePath
".exe"
  | Bool
otherwise = FilePath
""

-- | The file extension for executables.
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


-- | Creates a symbolic link on unix and a fake symlink on windows for
-- executables, which:
--     1. is a shim exe
--     2. has a corresponding .shim file in the same directory that
--        contains the target
--
-- This overwrites previously existing files.
--
-- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m
              , MonadThrow m
              , HasLog env
              , MonadIO m
              , MonadReader env m
              , HasDirs env
              , MonadUnliftIO m
              , MonadFail m
              )
           => FilePath      -- ^ path to the target executable
           -> FilePath      -- ^ path to be created
           -> 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"
          -- For hardlinks, link needs to be absolute.
          -- If link is relative, it's relative to the target exe.
          -- Note that (</>) drops lhs when rhs is absolute.
          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