427 lines
14 KiB
Haskell
427 lines
14 KiB
Haskell
{-# 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 _ (GHCupBinDir fp) _ _ _ =
|
|
throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
|
|
mergeFileTree sourceBase destBase tool v' copyOp = do
|
|
lift $ logInfo $ "Merging file tree from \""
|
|
<> T.pack (fromGHCupPath sourceBase)
|
|
<> "\" to \""
|
|
<> T.pack (fromInstallDir destBase)
|
|
<> "\""
|
|
recFile <- recordedInstallationFile tool v'
|
|
|
|
wrapInExcepts $ 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.
|
|
liftIO $ baseCheck (fromGHCupPath sourceBase)
|
|
liftIO $ destCheck (fromInstallDir destBase)
|
|
|
|
-- we only record for non-isolated installs
|
|
when (isSafeDir destBase) $ do
|
|
whenM (liftIO $ doesFileExist recFile)
|
|
$ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
|
|
liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
|
|
|
|
-- we want the cleanup action to leak through in case of exception
|
|
onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do
|
|
logDebug "Starting merge"
|
|
lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
|
|
copy f
|
|
logDebug $ T.pack "Recording installed file: " <> T.pack f
|
|
recordInstalledFile f recFile
|
|
pure f
|
|
|
|
where
|
|
wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))
|
|
|
|
cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do
|
|
(force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO
|
|
(readFile recFile >>= evaluate)
|
|
logDebug "Deleting recorded files due to partial install"
|
|
forM_ l $ \f -> do
|
|
let dest = fromInstallDir destBase </> dropDrive f
|
|
logDebug $ "rm -f " <> T.pack f
|
|
hideError NoSuchThing $ rmFile dest
|
|
pure ()
|
|
logDebug $ "rm -f " <> T.pack recFile
|
|
hideError NoSuchThing $ rmFile recFile
|
|
logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)
|
|
hideError UnsatisfiedConstraints $ hideError NoSuchThing $
|
|
removeEmptyDirsRecursive (fromInstallDir destBase)
|
|
|
|
|
|
recordInstalledFile f recFile = when (isSafeDir destBase) $
|
|
liftIO $ appendFile recFile (f <> "\n")
|
|
|
|
copy source = do
|
|
let dest = fromInstallDir destBase </> source
|
|
src = fromGHCupPath sourceBase </> source
|
|
|
|
when (isAbsolute source)
|
|
$ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
|
|
|
|
liftIO . createDirectoryIfMissing True . takeDirectory $ dest
|
|
|
|
copyOp src dest
|
|
|
|
|
|
baseCheck src = do
|
|
when (isRelative src)
|
|
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
|
|
whenM (not <$> doesDirectoryExist src)
|
|
$ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
|
|
destCheck dest = do
|
|
when (isRelative dest)
|
|
$ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
|
|
|
|
|
|
|
|
copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
|
|
copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from 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 (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
|
|
|
|
-- breadth first
|
|
getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
|
=> GHCupPath
|
|
-> S.SerialT m FilePath
|
|
getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
|
|
|
|
|
|
getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
|
=> GHCupPath
|
|
-> S.SerialT m FilePath
|
|
getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
|
|
|
|
getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
|
|
=> FilePath
|
|
-> S.SerialT m FilePath
|
|
getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
|
|
|
|
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
|
|
findFilesDeep path regex =
|
|
S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
|
|
|
|
|
|
recordedInstallationFile :: ( MonadReader env m
|
|
, HasDirs env
|
|
)
|
|
=> Tool
|
|
-> GHCTargetVersion
|
|
-> m FilePath
|
|
recordedInstallationFile t v' = do
|
|
Dirs {..} <- getDirs
|
|
pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
|
|
|
|
removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
|
removeDirIfEmptyOrIsSymlink filepath =
|
|
hideError UnsatisfiedConstraints $
|
|
handleIO' InappropriateType
|
|
(handleIfSym filepath)
|
|
(liftIO $ removeEmptyDirectory filepath)
|
|
where
|
|
handleIfSym fp e = do
|
|
isSym <- liftIO $ pathIsSymbolicLink fp
|
|
if isSym
|
|
then rmFileForce fp
|
|
else liftIO $ ioError e
|
|
|
|
removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
|
removeEmptyDirsRecursive = go
|
|
where
|
|
go fp = do
|
|
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
|
|
forM_ cs go
|
|
liftIO $ removeEmptyDirectory fp
|
|
|
|
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
|
|
rmFileForce filepath = do
|
|
hideError doesNotExistErrorType
|
|
$ hideError InappropriateType $ rmFile filepath
|
|
|
|
-- | More permissive version of 'createDirRecursive'. This doesn't
|
|
-- error when the destination is a symlink to a directory.
|
|
createDirRecursive' :: FilePath -> IO ()
|
|
createDirRecursive' p =
|
|
handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
|
|
. createDirectoryIfMissing True
|
|
$ p
|
|
|
|
where
|
|
isSymlinkDir e = do
|
|
ft <- pathIsSymbolicLink p
|
|
case ft of
|
|
True -> do
|
|
rp <- canonicalizePath p
|
|
rft <- doesDirectoryExist rp
|
|
case rft of
|
|
True -> pure ()
|
|
_ -> throwIO e
|
|
_ -> throwIO 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 fp
|
|
| isWindows = do
|
|
Dirs { recycleDir } <- getDirs
|
|
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
|
|
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
|
|
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
|
|
`catch`
|
|
(\e -> if | isDoesNotExistError e -> pure ()
|
|
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
|
|
| otherwise -> throwIO e)
|
|
`finally`
|
|
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
|
| otherwise = liftIO $ removePathForcibly fp
|
|
|
|
|
|
|
|
rmDirectory :: (MonadIO m, MonadMask m)
|
|
=> GHCupPath
|
|
-> m ()
|
|
rmDirectory fp
|
|
| isWindows = recover (liftIO $ removeDirectory fp)
|
|
| otherwise = liftIO $ removeDirectory 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 fp
|
|
| isWindows = do
|
|
Dirs { recycleDir } <- getDirs
|
|
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
|
|
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
|
|
let dest = fromGHCupPath tmp </> takeFileName fp
|
|
liftIO (moveFile fp dest)
|
|
`catch`
|
|
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
|
|
`finally`
|
|
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
|
| otherwise = liftIO $ removeFile fp
|
|
|
|
|
|
rmFile :: ( MonadIO m
|
|
, MonadMask m
|
|
)
|
|
=> FilePath
|
|
-> m ()
|
|
rmFile fp
|
|
| isWindows = recover (liftIO $ removeFile fp)
|
|
| otherwise = liftIO $ removeFile fp
|
|
|
|
|
|
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
|
|
=> FilePath
|
|
-> m ()
|
|
rmDirectoryLink fp
|
|
| isWindows = recover (liftIO $ removeDirectoryLink fp)
|
|
| otherwise = liftIO $ removeDirectoryLink fp
|
|
|
|
|
|
rmPathForcibly :: ( MonadIO m
|
|
, MonadMask m
|
|
)
|
|
=> GHCupPath
|
|
-> m ()
|
|
rmPathForcibly fp
|
|
| isWindows = recover (liftIO $ removePathForcibly fp)
|
|
| otherwise = liftIO $ removePathForcibly fp
|
|
|
|
|
|
-- | The file extension for executables.
|
|
exeExt :: String
|
|
exeExt
|
|
| isWindows = ".exe"
|
|
| otherwise = ""
|
|
|
|
-- | The file extension for executables.
|
|
exeExt' :: ByteString
|
|
exeExt'
|
|
| isWindows = ".exe"
|
|
| otherwise = ""
|
|
|
|
|
|
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
|
|
rmLink fp
|
|
| isWindows = do
|
|
hideError doesNotExistErrorType . recycleFile $ fp
|
|
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
|
|
| otherwise = hideError doesNotExistErrorType . recycleFile $ 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 'ensureShimGen' 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 link exe
|
|
| isWindows = do
|
|
dirs <- getDirs
|
|
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
|
|
|
|
let shim = dropExtension exe <.> "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 = takeDirectory exe </> link
|
|
shimContents = "path = " <> fullLink
|
|
|
|
logDebug $ "rm -f " <> T.pack exe
|
|
rmLink exe
|
|
|
|
logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
|
|
liftIO $ copyFile shimGen exe False
|
|
liftIO $ writeFile shim shimContents
|
|
| otherwise = do
|
|
logDebug $ "rm -f " <> T.pack exe
|
|
hideError doesNotExistErrorType $ recycleFile exe
|
|
|
|
logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
|
|
liftIO $ createFileLink link exe
|