ghcup-hs/lib/GHCup/Utils/File.hs
2022-05-16 11:29:55 +02:00

161 lines
5.5 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.File (
mergeFileTree,
copyFileE,
findFilesDeep,
getDirectoryContentsRecursive,
getDirectoryContentsRecursiveBFS,
getDirectoryContentsRecursiveDFS,
getDirectoryContentsRecursiveUnsafe,
getDirectoryContentsRecursiveBFSUnsafe,
getDirectoryContentsRecursiveDFSUnsafe,
recordedInstallationFile,
module GHCup.Utils.File.Common,
executeOut,
execLogged,
exec,
toProcessError,
chmod_755,
isBrokenSymlink,
copyFile,
deleteFile,
install,
removeEmptyDirectory,
) where
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
#else
import GHCup.Utils.File.Posix
#endif
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Prelude
import Text.Regex.Posix
import Control.Exception.Safe
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
import System.FilePath
import Text.PrettyPrint.HughesPJClass (prettyShow)
import qualified Data.Text as T
import qualified Streamly.Prelude as S
mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env)
=> GHCupPath -- ^ source base directory from which to install findFiles
-> InstallDirResolved -- ^ destination base dir
-> Tool
-> GHCTargetVersion
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m ()
mergeFileTree sourceBase destBase tool v' copyOp = 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)
recFile <- recordedInstallationFile tool v'
case destBase of
IsolateDirResolved _ -> pure ()
_ -> do
whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
copy f
recordInstalledFile f recFile
pure f
where
recordInstalledFile f recFile = do
case destBase of
IsolateDirResolved _ -> pure ()
_ -> 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'))