hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve error handling for mergeFileTree

Browse Source
This commit is contained in:
Julian Ospald 2022-05-19 23:17:58 +02:00
parent 1cffa358b8
commit 430b655785
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 149 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/ghcup/BrickMain.hs
View File

@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do
, ProcessError
, GHCupShadowed
, UninstallFailed
, MergeFileTreeError
]
run (do

2
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -389,6 +389,7 @@ type GHCEffects = '[ AlreadyInstalled
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
]
type HLSEffects = '[ AlreadyInstalled
, BuildFailed
@ -408,6 +409,7 @@ type HLSEffects = '[ AlreadyInstalled
, DirNotEmpty
, ArchiveResult
, UninstallFailed
, MergeFileTreeError
]

6
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -259,6 +259,7 @@ type InstallEffects = '[ AlreadyInstalled
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
, MergeFileTreeError
, (AlreadyInstalled, ())
, (UnknownArchive, ())
@ -267,6 +268,7 @@ type InstallEffects = '[ AlreadyInstalled
, (CopyError, ())
, (NotInstalled, ())
, (UninstallFailed, ())
, (MergeFileTreeError, ())
, (DirNotEmpty, ())
, (NoDownload, ())
, (BuildFailed, ())
@ -290,6 +292,7 @@ type InstallEffects = '[ AlreadyInstalled
, (NoDownload, NotInstalled)
, (NotInstalled, NotInstalled)
, (UninstallFailed, NotInstalled)
, (MergeFileTreeError, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
@ -323,6 +326,7 @@ type InstallGHCEffects = '[ TagNotFound
, DirNotEmpty
, AlreadyInstalled
, UninstallFailed
, MergeFileTreeError
, (AlreadyInstalled, NotInstalled)
, (UnknownArchive, NotInstalled)
@ -333,6 +337,7 @@ type InstallGHCEffects = '[ TagNotFound
, (DirNotEmpty, NotInstalled)
, (NoDownload, NotInstalled)
, (UninstallFailed, NotInstalled)
, (MergeFileTreeError, NotInstalled)
, (BuildFailed, NotInstalled)
, (TagNotFound, NotInstalled)
, (DigestError, NotInstalled)
@ -353,6 +358,7 @@ type InstallGHCEffects = '[ TagNotFound
, (DirNotEmpty, ())
, (NoDownload, ())
, (UninstallFailed, ())
, (MergeFileTreeError, ())
, (BuildFailed, ())
, (TagNotFound, ())
, (DigestError, ())

2
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -176,6 +176,7 @@ type RunEffects = '[ AlreadyInstalled
, FileAlreadyExistsError
, ProcessError
, UninstallFailed
, MergeFileTreeError
]
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@ -340,6 +341,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, FileAlreadyExistsError
, CopyError
, UninstallFailed
, MergeFileTreeError
] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do

53
lib/GHCup.hs
View File

@ -199,6 +199,7 @@ installGHCBindist :: ( MonadFail m
, ArchiveResult
, ProcessError
, UninstallFailed
, MergeFileTreeError
]
m
()
@ -280,6 +281,7 @@ installPackedGHC :: ( MonadMask m
, DirNotEmpty
, ArchiveResult
, ProcessError
, MergeFileTreeError
] m ()
installPackedGHC dl msubdir inst ver forceInstall = do
PlatformRequest {..} <- lift getPlatformReq
@ -319,14 +321,14 @@ installUnpackedGHC :: ( MonadReader env m
-> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version
-> Bool -- ^ Force install
-> Excepts '[ProcessError] m ()
-> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC path inst ver forceInstall
| isWindows = do
lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do
liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> liftIO $ do
mtime <- getModificationTime source
moveFilePortable source dest
setModificationTime dest mtime
@ -349,9 +351,8 @@ installUnpackedGHC path inst ver forceInstall
Nothing
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)
lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
inst
GHC
(mkTVer ver)
@ -394,6 +395,7 @@ installGHCBin :: ( MonadFail m
, ArchiveResult
, ProcessError
, UninstallFailed
, MergeFileTreeError
]
m
()
@ -576,6 +578,7 @@ installHLSBindist :: ( MonadMask m
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
@ -658,14 +661,14 @@ installHLSUnpacked :: ( MonadMask m
-> InstallDirResolved -- ^ Path to install to
-> Version
-> Bool
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
-> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
installHLSUnpacked path inst ver forceInstall = do
PlatformRequest { .. } <- lift getPlatformReq
lift $ logInfo "Installing HLS"
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)
lift $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
inst
HLS
(mkTVer ver)
@ -759,6 +762,7 @@ installHLSBin :: ( MonadMask m
, ProcessError
, DirNotEmpty
, UninstallFailed
, MergeFileTreeError
]
m
()
@ -1798,7 +1802,7 @@ rmGHCVer ver = do
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (lift . recycleFile . (\f -> dir </> dropDrive f))
removeEmptyDirsRecursive dir
removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
f <- recordedInstallationFile GHC ver
lift $ recycleFile f
@ -1882,7 +1886,7 @@ rmHLSVer ver = do
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
forM_ files (lift . recycleFile . (\f -> hlsDir </> dropDrive f))
removeEmptyDirsRecursive hlsDir
removeEmptyDirsRecursive (liftIO . removeEmptyDirectory) hlsDir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir
f <- recordedInstallationFile HLS (mkTVer ver)
lift $ recycleFile f
@ -2038,7 +2042,7 @@ rmGhcupDirs = do
logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")
handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir)
handleRm $ removeEmptyDirsRecursive removeDirIfEmptyOrIsSymlink (fromGHCupPath baseDir)
-- report files in baseDir that are left-over after
-- the standard location deletions above
@ -2052,12 +2056,12 @@ rmGhcupDirs = do
rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ deleteFile' enFilePath
hideErrorDef [permissionErrorType] () $ rmFileForce enFilePath
rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath
hideErrorDef [permissionErrorType] () $ rmFileForce confFilePath
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmBinDir binDir
@ -2084,33 +2088,7 @@ rmGhcupDirs = do
compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
-- we expect only files inside cache/log dir
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
deleteFile' :: (MonadMask m, MonadIO m) => FilePath -> m ()
deleteFile' filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, 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 deleteFile' fp
else liftIO $ ioError e
removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive fp = do
cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
------------------
@ -2195,6 +2173,7 @@ compileGHC :: ( MonadMask m
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
]
m
GHCTargetVersion

9
lib/GHCup/Errors.hs
View File

@ -105,6 +105,15 @@ instance Pretty CopyError where
pPrint (CopyError reason) =
text ("Unable to copy a file. Reason was: " ++ reason)
-- | Unable to merge file trees.
data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
deriving Show
instance Pretty MergeFileTreeError where
pPrint (MergeFileTreeError e from to) =
text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
<+> text "\n...tried to clean up" <+> text to <+> text ". Make sure it's gone."
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool
deriving Show

14
lib/GHCup/Types.hs
View File

@ -647,3 +647,17 @@ fromInstallDir :: InstallDirResolved -> FilePath
fromInstallDir (IsolateDirResolved fp) = fp
fromInstallDir (GHCupDir fp) = fromGHCupPath fp
fromInstallDir (GHCupBinDir fp) = fp
isSafeDir :: InstallDirResolved -> Bool
isSafeDir (IsolateDirResolved _) = False
isSafeDir (GHCupDir _) = True
isSafeDir (GHCupBinDir _) = False

121
lib/GHCup/Utils/File.hs
View File

@ -1,8 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@ -29,6 +31,9 @@ module GHCup.Utils.File (
deleteFile,
install,
removeEmptyDirectory,
removeDirIfEmptyOrIsSymlink,
removeEmptyDirsRecursive,
rmFileForce
) where
import GHCup.Utils.Dirs
@ -52,40 +57,87 @@ 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
import GHCup.Utils.Logger
mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env)
-- | 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
-> m ()
-> Excepts '[MergeFileTreeError] m ()
mergeFileTree _ (GHCupBinDir fp) _ _ _ =
throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
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)
lift $ logInfo $ "Merging file tree from \""
<> T.pack (fromGHCupPath sourceBase)
<> "\" to \""
<> T.pack (fromInstallDir destBase)
<> "\""
recFile <- recordedInstallationFile tool v'
case destBase of
IsolateDirResolved _ -> pure ()
_ -> do
whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
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)
flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
copy f
recordInstalledFile f recFile
pure f
-- 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
recordInstalledFile f recFile = do
case destBase of
IsolateDirResolved _ -> pure ()
_ -> liftIO $ appendFile recFile (f <> "\n")
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")
copy source = do
let dest = fromInstallDir destBase </> source
@ -158,3 +210,28 @@ 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