From 1c2cf9885070ee9918755c032bdccaa754738a33 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Wed, 21 Jul 2021 15:43:45 +0200
Subject: [PATCH] Fix file/dir removal on windows, fixes #165
---
app/ghcup/Main.hs | 6 ++-
ghcup.cabal | 1 +
lib/GHCup.hs | 71 +++++++++++++++++----------------
lib/GHCup/Download.hs | 9 +++--
lib/GHCup/Types/Optics.hs | 5 +++
lib/GHCup/Utils.hs | 34 ++++++++--------
lib/GHCup/Utils/Dirs.hs | 46 +++++++++++++++++++---
lib/GHCup/Utils/Logger.hs | 32 +++++++++------
lib/GHCup/Utils/Prelude.hs | 81 ++++++++++++++++++++++++++++++++------
9 files changed, 202 insertions(+), 83 deletions(-)
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
index f5aefcd6..9a97b1d3 100644
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -34,6 +34,7 @@ import GHCup.Version
import Codec.Archive
#endif
import Control.Concurrent
+import Control.Concurrent.Async
import Control.DeepSeq ( force )
import Control.Exception ( evaluate )
import Control.Exception.Safe
@@ -1342,7 +1343,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
- logfile <- initGHCupFileLogging logsDir
+ logfile <- flip runReaderT dirs $ initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
@@ -1386,6 +1387,9 @@ 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|]))
+
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure ()
diff --git a/ghcup.cabal b/ghcup.cabal
index 1237bf61..330069d7 100644
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -202,6 +202,7 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded
build-depends:
+ , async ^>=2.2.3
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
diff --git a/lib/GHCup.hs b/lib/GHCup.hs
index f348f10d..e1fd8461 100644
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -257,7 +257,7 @@ installPackedGHC dl msubdir inst ver = do
Dirs { tmpDir } <- lift getDirs
unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
- liftIO $ rmFile unpackDir
+ lift $ rmFile unpackDir
liftE $ unpackToDir unpackDir dl
@@ -266,7 +266,7 @@ installPackedGHC dl msubdir inst ver = do
Nothing -> pure unpackDir
liftIO $ Win32.moveFileEx d (Just inst) 0
- liftIO $ rmPath unpackDir
+ lift $ rmPathForcibly unpackDir
#else
PlatformRequest {..} <- lift getPlatformReq
@@ -801,7 +801,10 @@ setGHC ver sghc = do
symlinkShareDir :: ( MonadReader env m
, HasDirs env
, MonadIO m
- , MonadLogger m)
+ , MonadLogger m
+ , MonadCatch m
+ , MonadMask m
+ )
=> FilePath
-> String
-> m ()
@@ -816,7 +819,7 @@ setGHC ver sghc = do
let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) [i|rm -f #{fullF}|]
- liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF
+ hideError doesNotExistErrorType $ rmDirectoryLink fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO
#if defined(IS_WINDOWS)
@@ -884,7 +887,7 @@ setHLS ver = do
oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{binDir </> f}|]
- liftIO $ rmLink (binDir </> f)
+ lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver
@@ -1307,7 +1310,7 @@ rmGHCVer ver = do
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
- liftIO $ rmPath dir
+ lift $ rmPathForcibly dir
v' <-
handle
@@ -1319,7 +1322,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs
- liftIO
+ lift
$ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share")
@@ -1346,13 +1349,13 @@ rmCabalVer ver = do
Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
- liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
+ lift $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver
- Nothing -> liftIO $ rmLink (binDir </> "cabal" <> exeExt)
+ Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)
-- | Delete a hls version. Will try to fix the hls symlinks
@@ -1377,7 +1380,7 @@ rmHLSVer ver = do
Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver
- forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
+ forM_ bins $ \f -> lift $ rmFile (binDir </> f)
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
@@ -1385,7 +1388,7 @@ rmHLSVer ver = do
forM_ oldSyms $ \f -> do
let fullF = binDir </> f
lift $ $(logDebug) [i|rm #{fullF}|]
- liftIO $ rmLink fullF
+ lift $ rmLink fullF
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
@@ -1415,13 +1418,13 @@ rmStackVer ver = do
Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
- liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
+ lift $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver
- Nothing -> liftIO $ rmLink (binDir </> "stack" <> exeExt)
+ Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)
-- assuming the current scheme of having just 1 ghcup bin, no version info is required.
@@ -1430,10 +1433,11 @@ rmGhcup :: ( MonadReader env m
, MonadIO m
, MonadCatch m
, MonadLogger m
+ , MonadMask m
)
=> m ()
rmGhcup = do
- Dirs {binDir} <- getDirs
+ Dirs { .. } <- getDirs
let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename
@@ -1457,14 +1461,13 @@ rmGhcup = do
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exec in windows
-- we move it to temp dir, to be deleted at next reboot
- tempDir <- liftIO $ getTemporaryDirectory
- let tempFilepath = tempDir </> ghcupFilename
+ let tempFilepath = tmpDir </> ghcupFilename
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
#else
-- delete it.
- hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
+ hideError doesNotExistErrorType $ rmFile ghcupFilepath
#endif
where
@@ -1526,7 +1529,7 @@ rmGhcupDirs = do
rmDir (baseDir </> "msys64")
#endif
- liftIO $ removeEmptyDirsRecursive baseDir
+ removeEmptyDirsRecursive baseDir
-- report files in baseDir that are left-over after
-- the standard location deletions above
@@ -1534,17 +1537,17 @@ rmGhcupDirs = do
where
- rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+ rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File"
- liftIO $ deleteFile enFilePath
+ deleteFile enFilePath
- rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+ rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File"
- liftIO $ deleteFile confFilePath
+ deleteFile confFilePath
- rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
+ rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
@@ -1552,9 +1555,9 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] () $ do
$logInfo [i|removing #{dir}|]
contents <- liftIO $ getDirectoryContentsRecursive dir
- forM_ contents (liftIO . deleteFile . (dir </>))
+ forM_ contents (deleteFile . (dir </>))
- rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+ rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmBinDir binDir = do
#if !defined(IS_WINDOWS)
isXDGStyle <- liftIO useXDG
@@ -1583,9 +1586,9 @@ rmGhcupDirs = do
compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
- removeEmptyDirsRecursive :: FilePath -> IO ()
+ removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeEmptyDirsRecursive fp = do
- cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
+ cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
@@ -1594,22 +1597,22 @@ rmGhcupDirs = do
-- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below.
- deleteFile :: FilePath -> IO ()
+ deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
deleteFile filepath = do
hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath
- removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+ removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
- (liftIO $ removeDirectory filepath)
+ (liftIO $ rmPath filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
if isSym
- then liftIO $ deleteFile fp
+ then deleteFile fp
else liftIO $ ioError e
@@ -2137,8 +2140,8 @@ upgradeGHCup mtarget force' = do
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir
#if defined(IS_WINDOWS)
- let tempGhcup = cacheDir </> "ghcup.old"
- liftIO $ hideError NoSuchThing $ rmFile tempGhcup
+ 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
@@ -2149,7 +2152,7 @@ upgradeGHCup mtarget force' = do
destFile
#else
lift $ $(logDebug) [i|rm -f #{destFile}|]
- liftIO $ hideError NoSuchThing $ rmFile destFile
+ lift $ hideError NoSuchThing $ rmFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs
index b9f01256..8f19ccb3 100644
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -115,6 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m
, MonadThrow m
, MonadFail m
+ , MonadMask m
)
=> Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError]
@@ -170,6 +171,7 @@ getBase :: ( MonadReader env m
, MonadIO m
, MonadCatch m
, MonadLogger m
+ , MonadMask m
)
=> URI
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
@@ -208,6 +210,7 @@ getBase uri = do
, MonadIO m1
, MonadFail m1
, MonadLogger m1
+ , MonadMask m1
)
=> URI
-> Excepts
@@ -262,7 +265,7 @@ getBase uri = do
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
- liftIO $ hideError doesNotExistErrorType $ rmFile json_file
+ lift $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -385,10 +388,10 @@ download dli dest mfn
-- download
flip onException
- (liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
+ (lift $ hideError doesNotExistErrorType $ rmFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
- liftIO (hideError doesNotExistErrorType $ rmFile destFile)
+ lift (hideError doesNotExistErrorType $ rmFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
Settings{ downloader, noNetwork } <- lift getSettings
diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs
index 320e54b2..8cdaa7c4 100644
--- a/lib/GHCup/Types/Optics.hs
+++ b/lib/GHCup/Types/Optics.hs
@@ -1,9 +1,11 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-|
Module : GHCup.Types.Optics
@@ -143,3 +145,6 @@ getCache = getSettings <&> cache
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
getDownloader = getSettings <&> downloader
+
+instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
+ labelOptic = lens id (\_ d -> d)
diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs
index 09ab375e..eb2228e1 100644
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -123,6 +123,7 @@ rmMinorSymlinks :: ( MonadReader env m
, MonadLogger m
, MonadThrow m
, MonadFail m
+ , MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@@ -134,7 +135,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{fullF}|]
- liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+ lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the set ghc version for the given target, if any.
@@ -144,6 +145,7 @@ rmPlain :: ( MonadReader env m
, MonadThrow m
, MonadFail m
, MonadIO m
+ , MonadMask m
)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
@@ -155,11 +157,11 @@ rmPlain target = do
forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|]
- liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+ lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|]
- liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
+ lift $ hideError doesNotExistErrorType $ rmLink hdc_file
-- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -169,6 +171,7 @@ rmMajorSymlinks :: ( MonadReader env m
, MonadLogger m
, MonadThrow m
, MonadFail m
+ , MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@@ -182,7 +185,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|]
- liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+ lift $ hideError doesNotExistErrorType $ rmLink fullF
@@ -892,11 +895,11 @@ runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
- liftIO $ hideError doesNotExistErrorType $ rmPath dir
+ lift $ hideError doesNotExistErrorType $ rmPathForcibly dir
when (keepDirs == Never)
- $ liftIO
+ $ lift
$ hideError doesNotExistErrorType
- $ rmPath bdir
+ $ rmPathForcibly bdir
v <-
flip onException exAction
$ catchAllE
@@ -905,7 +908,7 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
- when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
+ when (keepDirs == Never || keepDirs == Errors) $ lift $ rmPathForcibly bdir
pure v
@@ -995,13 +998,13 @@ pathIsLink = pathIsSymbolicLink
#endif
-rmLink :: FilePath -> IO ()
+rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS)
rmLink fp = do
- hideError doesNotExistErrorType . liftIO . rmFile $ fp
- hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
+ hideError doesNotExistErrorType . rmFile $ fp
+ hideError doesNotExistErrorType . rmFile $ (dropExtension fp <.> "shim")
#else
-rmLink = hideError doesNotExistErrorType . liftIO . rmFile
+rmLink = hideError doesNotExistErrorType . rmFile
#endif
@@ -1039,14 +1042,14 @@ createLink link exe = do
shimContents = "path = " <> fullLink
$(logDebug) [i|rm -f #{exe}|]
- liftIO $ rmLink exe
+ rmLink exe
$(logDebug) [i|ln -s #{fullLink} #{exe}|]
liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
- liftIO $ hideError doesNotExistErrorType $ rmFile exe
+ hideError doesNotExistErrorType $ rmFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
@@ -1068,7 +1071,6 @@ ensureGlobalTools :: ( MonadMask m
ensureGlobalTools = do
#if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
- settings <- lift getSettings
dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
@@ -1076,7 +1078,7 @@ ensureGlobalTools = do
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
- liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
+ lift $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index 2bdb524e..3d25063f 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS)
, useXDG
#endif
+ , cleanupGHCupTmp
)
where
@@ -53,9 +54,7 @@ import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
-#if !defined(IS_WINDOWS)
import System.Directory
-#endif
import System.DiskSpace
import System.Environment
import System.FilePath
@@ -262,8 +261,20 @@ parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
-mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
+mkGhcupTmpDir :: ( MonadReader env m
+ , HasDirs env
+ , MonadUnliftIO m
+ , MonadLogger m
+ , MonadCatch m
+ , MonadThrow m
+ , MonadMask 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?
@@ -281,10 +292,20 @@ mkGhcupTmpDir = do
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
+#endif
-withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
-withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
+withGHCupTmpDir :: ( MonadReader env m
+ , HasDirs env
+ , MonadUnliftIO m
+ , MonadLogger m
+ , MonadCatch m
+ , MonadResource m
+ , MonadThrow m
+ , MonadMask m
+ , MonadIO m)
+ => m FilePath
+withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (run . rmPathForcibly))
@@ -312,3 +333,18 @@ 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
+ if null contents
+ then pure ()
+ else do
+ $(logWarn) [i|Removing leftover files in #{tmpDir}|]
+ forM_ contents (\fp -> liftIO $ removePathForcibly (tmpDir </> fp))
diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs
index e82f8baf..3ce6afc8 100644
--- a/lib/GHCup/Utils/Logger.hs
+++ b/lib/GHCup/Utils/Logger.hs
@@ -14,12 +14,16 @@ Here we define our main logger.
-}
module GHCup.Utils.Logger where
+import GHCup.Types
+import GHCup.Types.Optics
import GHCup.Utils.File
import GHCup.Utils.String.QQ
+import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
+import Control.Monad.Reader
import Data.Char ( ord )
import Prelude hiding ( appendFile )
import System.Console.Pretty
@@ -79,17 +83,21 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr
-initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
-initGHCupFileLogging logsDir = do
+initGHCupFileLogging :: ( MonadReader env m
+ , HasDirs env
+ , MonadIO m
+ , MonadMask m
+ ) => m FilePath
+initGHCupFileLogging = do
+ Dirs { logsDir } <- getDirs
let logfile = logsDir </> "ghcup.log"
- liftIO $ do
- logFiles <- findFiles
- logsDir
- (makeRegexOpts compExtended
- execBlank
- ([s|^.*\.log$|] :: B.ByteString)
- )
- forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
+ logFiles <- liftIO $ findFiles
+ logsDir
+ (makeRegexOpts compExtended
+ execBlank
+ ([s|^.*\.log$|] :: B.ByteString)
+ )
+ forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
- writeFile logfile ""
- pure logfile
+ liftIO $ writeFile logfile ""
+ pure logfile
diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs
index 76fbd359..e222c15e 100644
--- a/lib/GHCup/Utils/Prelude.hs
+++ b/lib/GHCup/Utils/Prelude.hs
@@ -19,11 +19,16 @@ GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Utils.Prelude where
+#if defined(IS_WINDOWS)
+import GHCup.Types
+#endif
+import GHCup.Types.Optics
+
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
-import Control.Monad.Trans.Class ( lift )
+import Control.Monad.Reader
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.List ( nub )
@@ -35,6 +40,9 @@ import Data.Word8
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import System.IO.Error
+#if defined(IS_WINDOWS)
+import System.IO.Temp
+#endif
import System.IO.Unsafe
import System.Directory
import System.FilePath
@@ -54,6 +62,9 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
+#if defined(IS_WINDOWS)
+import qualified System.Win32.File as Win32
+#endif
@@ -370,9 +381,33 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
-- 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
+ , MonadMask m
+ )
+ => FilePath
+ -> m ()
+rmPathForcibly fp = do
+#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)
+#else
+ liftIO $ removeDirectoryRecursive fp
+#endif
+
rmPath :: (MonadIO m, MonadMask m)
- => FilePath
- -> m ()
+ => FilePath
+ -> m ()
rmPath fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
@@ -380,24 +415,46 @@ rmPath fp =
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
]
- (\_ -> liftIO $ removePathForcibly fp)
+ (\_ -> liftIO $ removeDirectory fp)
#else
- liftIO $ removeDirectoryRecursive fp
+ liftIO $ removeDirectory fp
#endif
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
-rmFile :: (MonadIO m, MonadMask m)
+rmFile :: ( MonadIO m
+ , MonadMask m
+ , MonadReader env m
+ , HasDirs env
+ )
=> FilePath
-> m ()
-rmFile fp =
+rmFile fp = do
#if defined(IS_WINDOWS)
- recovering (fullJitterBackoff 25000 <> limitRetries 10)
- [\_ -> Handler (\e -> pure $ isPermissionError e)
- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
- ]
- (\_ -> liftIO $ removeFile fp)
+ 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)
+#else
+ liftIO $ removeFile fp
+#endif
+
+
+rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
+ => FilePath
+ -> m ()
+rmDirectoryLink fp =
+#if defined(IS_WINDOWS)
+ rmPathForcibly fp
#else
liftIO $ removeFile fp
#endif
--
GitLab