ghcup-hs/lib/GHCup/Utils/File.hs

238 lines
8.5 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
2021-05-14 21:09:45 +00:00
module GHCup.Utils.File (
mergeFileTree,
copyFileE,
2022-05-14 15:58:11 +00:00
findFilesDeep,
getDirectoryContentsRecursive,
getDirectoryContentsRecursiveBFS,
getDirectoryContentsRecursiveDFS,
getDirectoryContentsRecursiveUnsafe,
getDirectoryContentsRecursiveBFSUnsafe,
getDirectoryContentsRecursiveDFSUnsafe,
recordedInstallationFile,
2021-05-14 21:09:45 +00:00
module GHCup.Utils.File.Common,
2022-05-14 15:58:11 +00:00
executeOut,
execLogged,
exec,
toProcessError,
chmod_755,
isBrokenSymlink,
copyFile,
deleteFile,
install,
removeEmptyDirectory,
removeDirIfEmptyOrIsSymlink,
removeEmptyDirsRecursive,
rmFileForce
2021-05-14 21:09:45 +00:00
) where
import GHCup.Utils.Dirs
2021-05-14 21:09:45 +00:00
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif
import GHCup.Errors
2022-05-14 15:58:11 +00:00
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Prelude
2022-05-14 15:58:11 +00:00
import Text.Regex.Posix
import Control.Exception.Safe
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
import System.FilePath
2022-05-14 15:58:11 +00:00
import Text.PrettyPrint.HughesPJClass (prettyShow)
2022-05-14 15:58:11 +00:00
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
import GHCup.Utils.Logger
-- | 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
2022-05-14 15:58:11 +00:00
-> 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)
2022-05-14 15:58:11 +00:00
mergeFileTree sourceBase destBase tool v' copyOp = do
lift $ logInfo $ "Merging file tree from \""
<> T.pack (fromGHCupPath sourceBase)
<> "\" to \""
<> T.pack (fromInstallDir destBase)
<> "\""
2022-05-14 15:58:11 +00:00
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!")
2022-05-14 15:58:11 +00:00
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 (hideError UnsatisfiedConstraints . liftIO . removeEmptyDirectory) (fromInstallDir destBase)
recordInstalledFile f recFile = when (isSafeDir destBase) $
liftIO $ appendFile recFile (f <> "\n")
2022-05-14 15:58:11 +00:00
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
2022-05-14 15:58:11 +00:00
-- | 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 ()) -> FilePath -> m ()
removeEmptyDirsRecursive rmOpt = go
where
go fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs go
hideError InappropriateType $ rmOpt fp
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath