Improve error handling for mergeFileTree

app/ghcup/BrickMain.hs

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

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
                   ]
 
 

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, ())

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

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

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

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
+
+
+
+
+
+
+
+

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
+  lift $ logInfo $ "Merging file tree from \""
-  -- the opportunity to abort before copying has started.
+       <> T.pack (fromGHCupPath sourceBase)
-  --
+       <> "\" to \""
-  -- The actual copying might still fail.
+       <> T.pack (fromInstallDir destBase)
-  liftIO $ baseCheck (fromGHCupPath sourceBase)
+       <> "\""
-  liftIO $ destCheck (fromInstallDir destBase)
-
   recFile <- recordedInstallationFile tool v'
-  case destBase of
+
-    IsolateDirResolved _ -> pure ()
+  wrapInExcepts $ do
-    _ -> do
+    -- These checks are not atomic, but we perform them to have
-      whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
+    -- 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
+  -- we want the cleanup action to leak through in case of exception
-    copy f
+  onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do
-    recordInstalledFile f recFile
+    logDebug "Starting merge"
-    pure f
+    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
+  wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))
-    case destBase of
+
-      IsolateDirResolved _ -> pure ()
+  cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do
-      _ -> liftIO $ appendFile recFile (f <> "\n")
+    (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