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

427 lines
14 KiB
Haskell
Raw Permalink 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
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.File (
mergeFileTree,
copyFileE,
2022-05-14 15:58:11 +00:00
findFilesDeep,
getDirectoryContentsRecursive,
getDirectoryContentsRecursiveBFS,
getDirectoryContentsRecursiveDFS,
getDirectoryContentsRecursiveUnsafe,
getDirectoryContentsRecursiveBFSUnsafe,
getDirectoryContentsRecursiveDFSUnsafe,
recordedInstallationFile,
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.File.Search,
2022-05-14 15:58:11 +00:00
chmod_755,
isBrokenSymlink,
copyFile,
deleteFile,
install,
removeEmptyDirectory,
removeDirIfEmptyOrIsSymlink,
removeEmptyDirsRecursive,
2022-05-20 21:19:33 +00:00
rmFileForce,
createDirRecursive',
recyclePathForcibly,
rmDirectory,
recycleFile,
rmFile,
rmDirectoryLink,
moveFilePortable,
2022-05-21 20:54:18 +00:00
moveFile,
rmPathForcibly,
exeExt,
exeExt',
getLinkTarget,
pathIsLink,
rmLink,
createLink
2021-05-14 21:09:45 +00:00
) where
import GHCup.Utils.Dirs
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
import GHCup.Prelude.Internal
import GHCup.Prelude.File.Search
2021-05-14 21:09:45 +00:00
#if IS_WINDOWS
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.File.Windows
import GHCup.Prelude.Windows
2021-05-14 21:09:45 +00:00
#else
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.File.Posix
import GHCup.Prelude.Posix
2021-05-14 21:09:45 +00:00
#endif
import GHCup.Errors
2022-05-14 15:58:11 +00:00
import GHCup.Types
import GHCup.Types.Optics
2022-05-14 15:58:11 +00:00
import Text.Regex.Posix
2022-05-21 20:54:18 +00:00
import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Control.Exception.Safe
import Control.Monad.Reader
2022-05-21 20:54:18 +00:00
import Data.ByteString ( ByteString )
import Haskus.Utils.Variant.Excepts
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
-- | 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 $
2022-05-19 22:46:50 +00:00
removeEmptyDirsRecursive (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
2022-05-19 22:46:50 +00:00
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
2022-05-19 22:46:50 +00:00
liftIO $ removeEmptyDirectory fp
rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
rmFileForce filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
2022-05-20 21:19:33 +00:00
-- | 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
2022-05-21 20:54:18 +00:00
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.
--
2023-11-13 07:37:36 +00:00
-- On windows, this requires that 'ensureShimGen' was run beforehand.
2022-05-21 20:54:18 +00:00
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