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

Fix file/dir removal on windows, fixes #165

Browse Source
This commit is contained in:
Julian Ospald
2021-07-21 15:43:45 +02:00
parent b35dbca22e
commit 1c2cf98850
9 changed files with 202 additions and 83 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -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))

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

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

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

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