From 430b6557852a6e9d07904e3dae7547e398c9d5cc Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 19 May 2022 23:17:58 +0200 Subject: [PATCH] Improve error handling for mergeFileTree --- app/ghcup/BrickMain.hs | 1 + app/ghcup/GHCup/OptParse/Compile.hs | 2 + app/ghcup/GHCup/OptParse/Install.hs | 6 ++ app/ghcup/GHCup/OptParse/Run.hs | 2 + lib/GHCup.hs | 53 ++++-------- lib/GHCup/Errors.hs | 9 +++ lib/GHCup/Types.hs | 14 ++++ lib/GHCup/Utils/File.hs | 121 +++++++++++++++++++++++----- 8 files changed, 149 insertions(+), 59 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e401ee3..aae119f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -438,6 +438,7 @@ install' _ (_, ListResult {..}) = do , ProcessError , GHCupShadowed , UninstallFailed + , MergeFileTreeError ] run (do diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index 6499b38..f578c46 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -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 ] diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index f2320a6..905ae64 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -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, ()) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 45cfce6..c5bc1ac 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 359bce7..36fdee5 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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 diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index 33c8332..6dd405f 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 609834f..7b22698 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 + + + + + + + + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 649163f..4aeec14 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -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