parent
1c2cf98850
commit
3bdc82c99b
GPG Key ID:
3786C5262ECB4A3F
@ -1387,8 +1387,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
exitWith (ExitFailure 2)
|
||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq
|
||||
|
||||
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupGHCupTmp)
|
||||
(threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{tmpDir} manually|]))
|
||||
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
|
||||
(threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
|
||||
|
||||
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
|
||||
@ -1422,6 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
-- Effect interpreters --
|
||||
-------------------------
|
||||
|
||||
|
||||
let runInstTool' appstate' mInstPlatform =
|
||||
runLogger
|
||||
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
|
||||
@ -1519,6 +1520,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let runRm =
|
||||
runLogger . runAppState . runE @'[NotInstalled]
|
||||
|
||||
let runNuke s' =
|
||||
runLogger . flip runReaderT s' . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
. runAppState
|
||||
@ -2067,7 +2071,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
)
|
||||
pure ExitSuccess
|
||||
Just uri -> do
|
||||
pfreq <- runAppState getPlatformReq
|
||||
s' <- appState
|
||||
pfreq <- flip runReaderT s' getPlatformReq
|
||||
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
|
||||
cmd = case _rPlatform pfreq of
|
||||
Darwin -> "open"
|
||||
@ -2077,7 +2082,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
if clOpen
|
||||
then do
|
||||
s' <- appState
|
||||
flip runReaderT s' $
|
||||
exec cmd
|
||||
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
|
||||
@ -2089,10 +2093,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
>> pure (ExitFailure 13)
|
||||
else putStrLn uri' >> pure ExitSuccess
|
||||
|
||||
Nuke ->
|
||||
runRm (do
|
||||
Nuke -> do
|
||||
s' <- liftIO appState
|
||||
void $ liftIO $ evaluate $ force s'
|
||||
runNuke s' (do
|
||||
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
|
||||
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
|
||||
liftIO $ threadDelay 10000000 -- wait 10s
|
||||
|
||||
100
lib/GHCup.hs
100
lib/GHCup.hs
@ -54,6 +54,9 @@ import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Resource
|
||||
hiding ( throwM )
|
||||
#if defined(IS_WINDOWS)
|
||||
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
|
||||
#endif
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Either
|
||||
import Data.List
|
||||
@ -252,22 +255,6 @@ installPackedGHC :: ( MonadMask m
|
||||
#endif
|
||||
] m ()
|
||||
installPackedGHC dl msubdir inst ver = do
|
||||
#if defined(IS_WINDOWS)
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
|
||||
Dirs { tmpDir } <- lift getDirs
|
||||
unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
|
||||
lift $ rmFile unpackDir
|
||||
|
||||
liftE $ unpackToDir unpackDir dl
|
||||
|
||||
d <- case msubdir of
|
||||
Just td -> liftE $ intoSubdir unpackDir td
|
||||
Nothing -> pure unpackDir
|
||||
|
||||
liftIO $ Win32.moveFileEx d (Just inst) 0
|
||||
lift $ rmPathForcibly unpackDir
|
||||
#else
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
|
||||
-- unpack
|
||||
@ -283,7 +270,6 @@ installPackedGHC dl msubdir inst ver = do
|
||||
liftE $ runBuildAction tmpUnpack
|
||||
(Just inst)
|
||||
(installUnpackedGHC workdir inst ver)
|
||||
#endif
|
||||
|
||||
|
||||
-- | Install an unpacked GHC distribution. This only deals with the GHC
|
||||
@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
|
||||
, MonadThrow m
|
||||
, MonadLogger m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||
-> FilePath -- ^ Path to install to
|
||||
-> Version -- ^ The GHC version
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installUnpackedGHC path inst ver = do
|
||||
#if defined(IS_WINDOWS)
|
||||
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 $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
|
||||
mtime <- getModificationTime source
|
||||
Win32.moveFile source dest
|
||||
setModificationTime dest mtime
|
||||
#else
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
|
||||
mtime <- getModificationTime source
|
||||
copyFile source dest
|
||||
setModificationTime dest mtime
|
||||
|
||||
let alpineArgs
|
||||
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
|
||||
@ -312,9 +314,6 @@ installUnpackedGHC path inst ver = do
|
||||
lift $ $(logInfo) "Installing GHC (this may take a while)"
|
||||
lEM $ execLogged "sh"
|
||||
("./configure" : ("--prefix=" <> inst)
|
||||
#if defined(IS_WINDOWS)
|
||||
: "--enable-tarballs-autodownload"
|
||||
#endif
|
||||
: alpineArgs
|
||||
)
|
||||
(Just path)
|
||||
@ -322,6 +321,7 @@ installUnpackedGHC path inst ver = do
|
||||
Nothing
|
||||
lEM $ make ["install"] (Just path)
|
||||
pure ()
|
||||
#endif
|
||||
|
||||
|
||||
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
|
||||
@ -1310,7 +1310,7 @@ rmGHCVer ver = do
|
||||
-- then fix them (e.g. with an earlier version)
|
||||
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
|
||||
lift $ rmPathForcibly dir
|
||||
lift $ recyclePathForcibly dir
|
||||
|
||||
v' <-
|
||||
handle
|
||||
@ -1322,9 +1322,7 @@ rmGHCVer ver = do
|
||||
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
lift
|
||||
$ hideError doesNotExistErrorType
|
||||
$ rmFile (baseDir </> "share")
|
||||
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
|
||||
|
||||
|
||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||
@ -1349,7 +1347,7 @@ rmCabalVer ver = do
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
lift $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
|
||||
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
|
||||
|
||||
when (Just ver == cSet) $ do
|
||||
cVers <- lift $ fmap rights getInstalledCabals
|
||||
@ -1380,7 +1378,7 @@ rmHLSVer ver = do
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
bins <- lift $ hlsAllBinaries ver
|
||||
forM_ bins $ \f -> lift $ rmFile (binDir </> f)
|
||||
forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
|
||||
|
||||
when (Just ver == isHlsSet) $ do
|
||||
-- delete all set symlinks
|
||||
@ -1418,7 +1416,7 @@ rmStackVer ver = do
|
||||
Dirs {..} <- lift getDirs
|
||||
|
||||
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
|
||||
lift $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
|
||||
lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
|
||||
|
||||
when (Just ver == sSet) $ do
|
||||
sVers <- lift $ fmap rights getInstalledStacks
|
||||
@ -1434,6 +1432,7 @@ rmGhcup :: ( MonadReader env m
|
||||
, MonadCatch m
|
||||
, MonadLogger m
|
||||
, MonadMask m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> m ()
|
||||
rmGhcup = do
|
||||
@ -1459,12 +1458,12 @@ rmGhcup = do
|
||||
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
|
||||
|
||||
#if defined(IS_WINDOWS)
|
||||
-- since it doesn't seem possible to delete a running exec in windows
|
||||
-- since it doesn't seem possible to delete a running exe on windows
|
||||
-- we move it to temp dir, to be deleted at next reboot
|
||||
let tempFilepath = tmpDir </> ghcupFilename
|
||||
tempFilepath <- mkGhcupTmpDir
|
||||
hideError UnsupportedOperation $
|
||||
liftIO $ hideError NoSuchThing $
|
||||
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
|
||||
Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
|
||||
#else
|
||||
-- delete it.
|
||||
hideError doesNotExistErrorType $ rmFile ghcupFilepath
|
||||
@ -1512,30 +1511,34 @@ rmGhcupDirs = do
|
||||
, binDir
|
||||
, logsDir
|
||||
, cacheDir
|
||||
, tmpDir
|
||||
, recycleDir
|
||||
} <- getDirs
|
||||
|
||||
let envFilePath = baseDir </> "env"
|
||||
|
||||
confFilePath <- getConfigFilePath
|
||||
|
||||
rmEnvFile envFilePath
|
||||
rmConfFile confFilePath
|
||||
rmDir cacheDir
|
||||
rmDir logsDir
|
||||
rmBinDir binDir
|
||||
rmDir tmpDir
|
||||
handleRm $ rmEnvFile envFilePath
|
||||
handleRm $ rmConfFile confFilePath
|
||||
handleRm $ rmDir cacheDir
|
||||
handleRm $ rmDir logsDir
|
||||
handleRm $ rmBinDir binDir
|
||||
handleRm $ rmDir recycleDir
|
||||
#if defined(IS_WINDOWS)
|
||||
rmDir (baseDir </> "msys64")
|
||||
$logInfo [i|removing #{(baseDir </> "msys64")}|]
|
||||
handleRm $ rmPathForcibly (baseDir </> "msys64")
|
||||
#endif
|
||||
|
||||
removeEmptyDirsRecursive baseDir
|
||||
handleRm $ removeEmptyDirsRecursive baseDir
|
||||
|
||||
-- report files in baseDir that are left-over after
|
||||
-- the standard location deletions above
|
||||
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
|
||||
|
||||
where
|
||||
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
|
||||
handleRm = handleIO (\e -> $logWarn [i|Part of the cleanup action failed with error: #{displayException e}
|
||||
continuing regardless...|])
|
||||
|
||||
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
rmEnvFile enFilePath = do
|
||||
@ -1607,7 +1610,7 @@ rmGhcupDirs = do
|
||||
hideError UnsatisfiedConstraints $
|
||||
handleIO' InappropriateType
|
||||
(handleIfSym filepath)
|
||||
(liftIO $ rmPath filepath)
|
||||
(liftIO $ rmDirectory filepath)
|
||||
where
|
||||
handleIfSym fp e = do
|
||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||
@ -2136,27 +2139,14 @@ upgradeGHCup mtarget force' = do
|
||||
let fn = "ghcup" <> exeExt
|
||||
p <- liftE $ download dli tmp (Just fn)
|
||||
let destDir = takeDirectory destFile
|
||||
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
|
||||
destFile = fromMaybe (binDir </> fn) mtarget
|
||||
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
|
||||
liftIO $ createDirRecursive' destDir
|
||||
#if defined(IS_WINDOWS)
|
||||
let tempGhcup = tmpDir </> "ghcup.old"
|
||||
lift $ hideError NoSuchThing $ rmFile tempGhcup
|
||||
|
||||
lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
|
||||
-- NoSuchThing may be raised when we're updating ghcup from
|
||||
-- a non-standard location
|
||||
liftIO $ hideError NoSuchThing $ Win32.moveFileEx destFile (Just tempGhcup) 0
|
||||
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
destFile
|
||||
#else
|
||||
lift $ $(logDebug) [i|rm -f #{destFile}|]
|
||||
lift $ hideError NoSuchThing $ rmFile destFile
|
||||
lift $ hideError NoSuchThing $ recycleFile destFile
|
||||
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
|
||||
destFile
|
||||
#endif
|
||||
lift $ chmod_755 destFile
|
||||
|
||||
liftIO (isInPath destFile) >>= \b -> unless b $
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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,7 +887,16 @@ 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)
|
||||
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
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -30,7 +30,7 @@ module GHCup.Utils.Dirs
|
||||
#if !defined(IS_WINDOWS)
|
||||
, useXDG
|
||||
#endif
|
||||
, cleanupGHCupTmp
|
||||
, cleanupTrash
|
||||
)
|
||||
where
|
||||
|
||||
@ -190,12 +190,10 @@ 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")
|
||||
|
||||
|
||||
|
||||
@ -206,7 +204,7 @@ getAllDirs = do
|
||||
cacheDir <- ghcupCacheDir
|
||||
logsDir <- ghcupLogsDir
|
||||
confDir <- ghcupConfigDir
|
||||
tmpDir <- ghcupTmpDir
|
||||
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
|
||||
cleanupTrash :: ( MonadIO m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
)
|
||||
=> m ()
|
||||
cleanupGHCupTmp = do
|
||||
Dirs { tmpDir } <- getDirs
|
||||
contents <- liftIO $ listDirectory tmpDir
|
||||
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))
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
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
|
||||
recyclePathForcibly :: ( MonadIO m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
, MonadMask m
|
||||
)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmPathForcibly fp = do
|
||||
recyclePathForcibly fp = do
|
||||
#if defined(IS_WINDOWS)
|
||||
Dirs { tmpDir } <- getDirs
|
||||
tmp <- liftIO $ createTempDirectory tmpDir "rmPathForcibly"
|
||||
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 =
|
||||
#if defined(IS_WINDOWS)
|
||||
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)
|
||||
(\_ -> liftIO $ removePathForcibly fp)
|
||||
#else
|
||||
liftIO $ removeDirectoryRecursive fp
|
||||
liftIO $ removePathForcibly fp
|
||||
#endif
|
||||
|
||||
rmPath :: (MonadIO m, MonadMask m)
|
||||
|
||||
rmDirectory :: (MonadIO m, MonadMask m)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmPath fp =
|
||||
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
|
||||
rmFile :: ( MonadIO m
|
||||
recycleFile :: ( MonadIO m
|
||||
, MonadMask m
|
||||
, MonadReader env m
|
||||
, HasDirs env
|
||||
)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmFile fp = do
|
||||
recycleFile fp = do
|
||||
#if defined(IS_WINDOWS)
|
||||
Dirs { tmpDir } <- getDirs
|
||||
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "rmFile" "" Nothing (Just fp))
|
||||
tmp <- liftIO $ createTempDirectory tmpDir "rmFile"
|
||||
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
|
||||
)
|
||||
=> FilePath
|
||||
-> m ()
|
||||
rmFile fp =
|
||||
#if defined(IS_WINDOWS)
|
||||
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)
|
||||
(\_ -> 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
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user