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

Redo file handling wrt #165 and #187

Browse Source
This commit is contained in:
Julian Ospald
2021-07-22 15:45:08 +02:00
parent 1c2cf98850
commit 3bdc82c99b
8 changed files with 221 additions and 158 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
lib/GHCup/Download.hs
View File

@@ -265,7 +265,7 @@ getBase uri = do
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
lift $ hideError doesNotExistErrorType $ rmFile json_file
lift $ hideError doesNotExistErrorType $ recycleFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -388,10 +388,10 @@ download dli dest mfn
-- download
flip onException
(lift $ hideError doesNotExistErrorType $ rmFile destFile)
(lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
lift (hideError doesNotExistErrorType $ rmFile destFile)
lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
Settings{ downloader, noNetwork } <- lift getSettings

2
lib/GHCup/Types.hs
View File

@@ -384,7 +384,7 @@ data Dirs = Dirs
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
, tmpDir :: FilePath
, recycleDir :: FilePath -- mainly used on windows
}
deriving (Show, GHC.Generic)

47
lib/GHCup/Utils.hs
View File

@@ -53,6 +53,7 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
@@ -886,8 +887,17 @@ getChangeLog dls tool (Right tag) =
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Pretty (V e), Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
runBuildAction :: ( Pretty (V e)
, Show (V e)
, MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, MonadLogger m
, MonadUnliftIO m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
@@ -895,11 +905,9 @@ runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
lift $ hideError doesNotExistErrorType $ rmPathForcibly dir
lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never)
$ lift
$ hideError doesNotExistErrorType
$ rmPathForcibly bdir
$ lift $ rmBDir bdir
v <-
flip onException exAction
$ catchAllE
@@ -908,10 +916,20 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmPathForcibly bdir
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn)
[i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
@@ -1001,10 +1019,10 @@ pathIsLink = pathIsSymbolicLink
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS)
rmLink fp = do
hideError doesNotExistErrorType . rmFile $ fp
hideError doesNotExistErrorType . rmFile $ (dropExtension fp <.> "shim")
hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else
rmLink = hideError doesNotExistErrorType . rmFile
rmLink = hideError doesNotExistErrorType . recycleFile
#endif
@@ -1049,7 +1067,7 @@ createLink link exe = do
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
hideError doesNotExistErrorType $ rmFile exe
hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
@@ -1078,7 +1096,7 @@ ensureGlobalTools = do
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
lift $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
@@ -1089,14 +1107,14 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
createDirRecursive' tmpDir
createDirRecursive' trashDir
pure ()
@@ -1110,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)

66
lib/GHCup/Utils/Dirs.hs
View File

@@ -30,7 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS)
, useXDG
#endif
, cleanupGHCupTmp
, cleanupTrash
)
where
@@ -190,23 +190,21 @@ ghcupLogsDir = do
#endif
-- | Defaults to '~/.ghcup/tmp.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
getAllDirs :: IO Dirs
getAllDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
recycleDir <- ghcupRecycleDir
pure Dirs { .. }
@@ -271,10 +269,6 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadIO m)
=> m FilePath
mkGhcupTmpDir = do
#if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs
liftIO $ createTempDirectory tmpDir "ghcup"
#else
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
@@ -292,7 +286,6 @@ mkGhcupTmpDir = do
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
#endif
withGHCupTmpDir :: ( MonadReader env m
@@ -305,7 +298,15 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadMask m
, MonadIO m)
=> m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (run . rmPathForcibly))
withGHCupTmpDir = snd <$> withRunInIO (\run ->
run
$ allocate
(run mkGhcupTmpDir)
(\fp ->
handleIO (\e -> run
$ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
. rmPathForcibly
$ fp))
@@ -333,18 +334,21 @@ relativeSymlink p1 p2 =
<> joinPath ([pathSeparator] : drop (length common) d2)
cleanupGHCupTmp :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasDirs env
)
=> m ()
cleanupGHCupTmp = do
Dirs { tmpDir } <- getDirs
contents <- liftIO $ listDirectory tmpDir
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasDirs env
)
=> m ()
cleanupTrash = do
Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory recycleDir
if null contents
then pure ()
else do
$(logWarn) [i|Removing leftover files in #{tmpDir}|]
forM_ contents (\fp -> liftIO $ removePathForcibly (tmpDir </> fp))
$(logWarn) [i|Removing leftover files in #{recycleDir}|]
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
) $ liftIO $ removePathForcibly (recycleDir </> fp))

2
lib/GHCup/Utils/Logger.hs
View File

@@ -97,7 +97,7 @@ initGHCupFileLogging = do
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
liftIO $ writeFile logfile ""
pure logfile

136
lib/GHCup/Utils/Prelude.hs
View File

@@ -323,17 +323,16 @@ createDirRecursive' p =
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
| f <- srcFiles ]
copyFilesWith destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@@ -378,37 +377,54 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
ignore ['.', '.'] = True
ignore _ = False
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
rmPathForcibly :: (MonadIO m
, MonadReader env m
, HasDirs env
recyclePathForcibly :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadMask m
)
=> FilePath
-> m ()
recyclePathForcibly fp = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removePathForcibly fp
#endif
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
rmPathForcibly fp = do
rmPathForcibly fp =
#if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs
tmp <- liftIO $ createTempDirectory tmpDir "rmPathForcibly"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`finally`
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removePathForcibly tmp)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removePathForcibly fp)
#else
liftIO $ removeDirectoryRecursive fp
liftIO $ removePathForcibly fp
#endif
rmPath :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmPath fp =
rmDirectory :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmDirectory fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
@@ -423,27 +439,42 @@ rmPath 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 = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removeFile fp
#endif
rmFile :: ( MonadIO m
, MonadMask m
, MonadReader env m
, HasDirs env
)
=> FilePath
-> m ()
rmFile fp = do
rmFile fp =
#if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "rmFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory tmpDir "rmFile"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`finally`
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removePathForcibly tmp)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
@@ -454,9 +485,26 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-> m ()
rmDirectoryLink fp =
#if defined(IS_WINDOWS)
rmPathForcibly fp
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeDirectoryLink fp)
#else
liftIO $ removeFile fp
liftIO $ removeDirectoryLink fp
#endif
#if defined(IS_WINDOWS)
recover :: (MonadIO m, MonadMask m) => m a -> m a
recover action =
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> action)
#endif