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
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
9 changed files with 202 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
app/ghcup/Main.hs
View File

@ -34,6 +34,7 @@ import GHCup.Version
import Codec.Archive import Codec.Archive
#endif #endif
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async
import Control.DeepSeq ( force ) import Control.DeepSeq ( force )
import Control.Exception ( evaluate ) import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
@ -1342,7 +1343,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt (settings, keybindings) <- toSettings opt
-- logger interpreter -- logger interpreter
logfile <- initGHCupFileLogging logsDir logfile <- flip runReaderT dirs $ initGHCupFileLogging
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings { lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr , colorOutter = B.hPut stderr
@ -1386,6 +1387,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq 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 lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure () Just _ -> pure ()

1
ghcup.cabal
View File

@ -202,6 +202,7 @@ executable ghcup
-fwarn-incomplete-record-updates -threaded -fwarn-incomplete-record-updates -threaded
build-depends: build-depends:
, async ^>=2.2.3
, base >=4.13 && <5 , base >=4.13 && <5
, bytestring ^>=0.10 , bytestring ^>=0.10
, containers ^>=0.6 , containers ^>=0.6

71
lib/GHCup.hs
View File

@ -257,7 +257,7 @@ installPackedGHC dl msubdir inst ver = do
Dirs { tmpDir } <- lift getDirs Dirs { tmpDir } <- lift getDirs
unpackDir <- liftIO $ emptyTempFile tmpDir "ghc" unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
liftIO $ rmFile unpackDir lift $ rmFile unpackDir
liftE $ unpackToDir unpackDir dl liftE $ unpackToDir unpackDir dl
@ -266,7 +266,7 @@ installPackedGHC dl msubdir inst ver = do
Nothing -> pure unpackDir Nothing -> pure unpackDir
liftIO $ Win32.moveFileEx d (Just inst) 0 liftIO $ Win32.moveFileEx d (Just inst) 0
liftIO $ rmPath unpackDir lift $ rmPathForcibly unpackDir
#else #else
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
@ -801,7 +801,10 @@ setGHC ver sghc = do
symlinkShareDir :: ( MonadReader env m symlinkShareDir :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m) , MonadLogger m
, MonadCatch m
, MonadMask m
)
=> FilePath => FilePath
-> String -> String
-> m () -> m ()
@ -816,7 +819,7 @@ setGHC ver sghc = do
let fullF = destdir </> sharedir let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) [i|rm -f #{fullF}|] $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF hideError doesNotExistErrorType $ rmDirectoryLink fullF
$(logDebug) [i|ln -s #{targetF} #{fullF}|] $(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO liftIO
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
@ -884,7 +887,7 @@ setHLS ver = do
oldSyms <- lift hlsSymlinks oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do forM_ oldSyms $ \f -> do
lift $ $(logDebug) [i|rm #{binDir </> f}|] lift $ $(logDebug) [i|rm #{binDir </> f}|]
liftIO $ rmLink (binDir </> f) lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks -- set haskell-language-server-<ghcver> symlinks
bins <- lift $ hlsServerBinaries ver bins <- lift $ hlsServerBinaries ver
@ -1307,7 +1310,7 @@ rmGHCVer ver = do
-- then fix them (e.g. with an earlier version) -- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|] lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
liftIO $ rmPath dir lift $ rmPathForcibly dir
v' <- v' <-
handle handle
@ -1319,7 +1322,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
liftIO lift
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share") $ rmFile (baseDir </> "share")
@ -1346,13 +1349,13 @@ rmCabalVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt 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 when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
case headMay . reverse . sort $ cVers of case headMay . reverse . sort $ cVers of
Just latestver -> setCabal latestver 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 -- | Delete a hls version. Will try to fix the hls symlinks
@ -1377,7 +1380,7 @@ rmHLSVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f) forM_ bins $ \f -> lift $ rmFile (binDir </> f)
when (Just ver == isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- delete all set symlinks -- delete all set symlinks
@ -1385,7 +1388,7 @@ rmHLSVer ver = do
forM_ oldSyms $ \f -> do forM_ oldSyms $ \f -> do
let fullF = binDir </> f let fullF = binDir </> f
lift $ $(logDebug) [i|rm #{fullF}|] lift $ $(logDebug) [i|rm #{fullF}|]
liftIO $ rmLink fullF lift $ rmLink fullF
-- set latest hls -- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of case headMay . reverse . sort $ hlsVers of
@ -1415,13 +1418,13 @@ rmStackVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt 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 when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks sVers <- lift $ fmap rights getInstalledStacks
case headMay . reverse . sort $ sVers of case headMay . reverse . sort $ sVers of
Just latestver -> setStack latestver 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. -- 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 , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadMask m
) )
=> m () => m ()
rmGhcup = do rmGhcup = do
Dirs {binDir} <- getDirs Dirs { .. } <- getDirs
let ghcupFilename = "ghcup" <> exeExt let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename let ghcupFilepath = binDir </> ghcupFilename
@ -1457,14 +1461,13 @@ rmGhcup = do
#if defined(IS_WINDOWS) #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 exec in windows
-- we move it to temp dir, to be deleted at next reboot -- we move it to temp dir, to be deleted at next reboot
tempDir <- liftIO $ getTemporaryDirectory let tempFilepath = tmpDir </> ghcupFilename
let tempFilepath = tempDir </> ghcupFilename
hideError UnsupportedOperation $ hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $ liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
#else #else
-- delete it. -- delete it.
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath hideError doesNotExistErrorType $ rmFile ghcupFilepath
#endif #endif
where where
@ -1526,7 +1529,7 @@ rmGhcupDirs = do
rmDir (baseDir </> "msys64") rmDir (baseDir </> "msys64")
#endif #endif
liftIO $ removeEmptyDirsRecursive baseDir removeEmptyDirsRecursive baseDir
-- report files in baseDir that are left-over after -- report files in baseDir that are left-over after
-- the standard location deletions above -- the standard location deletions above
@ -1534,17 +1537,17 @@ rmGhcupDirs = do
where 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 rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File" $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 rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File" $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 = rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case -- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well, -- an error leaks through, we catch it here as well,
@ -1552,9 +1555,9 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] () $ do hideErrorDef [doesNotExistErrorType] () $ do
$logInfo [i|removing #{dir}|] $logInfo [i|removing #{dir}|]
contents <- liftIO $ getDirectoryContentsRecursive 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 rmBinDir binDir = do
#if !defined(IS_WINDOWS) #if !defined(IS_WINDOWS)
isXDGStyle <- liftIO useXDG isXDGStyle <- liftIO useXDG
@ -1583,9 +1586,9 @@ rmGhcupDirs = do
compareFn :: FilePath -> FilePath -> Ordering compareFn :: FilePath -> FilePath -> Ordering
compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2) 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 removeEmptyDirsRecursive fp = do
cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>) cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
forM_ cs removeEmptyDirsRecursive forM_ cs removeEmptyDirsRecursive
hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
@ -1594,22 +1597,22 @@ rmGhcupDirs = do
-- we report remaining files/dirs later, -- we report remaining files/dirs later,
-- hence the force/quiet mode in these delete functions below. -- 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 deleteFile filepath = do
hideError doesNotExistErrorType hideError doesNotExistErrorType
$ hideError InappropriateType $ rmFile filepath $ 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 = removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $ hideError UnsatisfiedConstraints $
handleIO' InappropriateType handleIO' InappropriateType
(handleIfSym filepath) (handleIfSym filepath)
(liftIO $ removeDirectory filepath) (liftIO $ rmPath filepath)
where where
handleIfSym fp e = do handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp isSym <- liftIO $ pathIsSymbolicLink fp
if isSym if isSym
then liftIO $ deleteFile fp then deleteFile fp
else liftIO $ ioError e else liftIO $ ioError e
@ -2137,8 +2140,8 @@ upgradeGHCup mtarget force' = do
lift $ $(logDebug) [i|mkdir -p #{destDir}|] lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir liftIO $ createDirRecursive' destDir
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
let tempGhcup = cacheDir </> "ghcup.old" let tempGhcup = tmpDir </> "ghcup.old"
liftIO $ hideError NoSuchThing $ rmFile tempGhcup lift $ hideError NoSuchThing $ rmFile tempGhcup
lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|] lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
-- NoSuchThing may be raised when we're updating ghcup from -- NoSuchThing may be raised when we're updating ghcup from
@ -2149,7 +2152,7 @@ upgradeGHCup mtarget force' = do
destFile destFile
#else #else
lift $ $(logDebug) [i|rm -f #{destFile}|] lift $ $(logDebug) [i|rm -f #{destFile}|]
liftIO $ hideError NoSuchThing $ rmFile destFile lift $ hideError NoSuchThing $ rmFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|] lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile destFile

9
lib/GHCup/Download.hs
View File

@ -115,6 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m
) )
=> Excepts => Excepts
'[JSONError , DownloadFailed , FileDoesNotExistError] '[JSONError , DownloadFailed , FileDoesNotExistError]
@ -170,6 +171,7 @@ getBase :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadMask m
) )
=> URI => URI
-> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
@ -208,6 +210,7 @@ getBase uri = do
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , MonadLogger m1
, MonadMask m1
) )
=> URI => URI
-> Excepts -> Excepts
@ -262,7 +265,7 @@ getBase uri = do
pure bs pure bs
dlWithoutMod json_file = do dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri' bs <- liftE $ downloadBS uri'
liftIO $ hideError doesNotExistErrorType $ rmFile json_file lift $ hideError doesNotExistErrorType $ rmFile json_file
liftIO $ L.writeFile json_file bs liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0)) liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs pure bs
@ -385,10 +388,10 @@ download dli dest mfn
-- download -- download
flip onException flip onException
(liftIO $ hideError doesNotExistErrorType $ rmFile destFile) (lift $ hideError doesNotExistErrorType $ rmFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme] $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e -> (\e ->
liftIO (hideError doesNotExistErrorType $ rmFile destFile) lift (hideError doesNotExistErrorType $ rmFile destFile)
>> (throwE . DownloadFailed $ e) >> (throwE . DownloadFailed $ e)
) $ do ) $ do
Settings{ downloader, noNetwork } <- lift getSettings Settings{ downloader, noNetwork } <- lift getSettings

5
lib/GHCup/Types/Optics.hs
View File

@ -1,9 +1,11 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-| {-|
Module : GHCup.Types.Optics Module : GHCup.Types.Optics
@ -143,3 +145,6 @@ getCache = getSettings <&> cache
getDownloader :: (MonadReader env m, HasSettings env) => m Downloader getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
getDownloader = getSettings <&> downloader getDownloader = getSettings <&> downloader
instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
labelOptic = lens id (\_ d -> d)

34
lib/GHCup/Utils.hs
View File

@ -123,6 +123,7 @@ rmMinorSymlinks :: ( MonadReader env m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@ -134,7 +135,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz let fullF = binDir </> f_xyz
lift $ $(logDebug) [i|rm -f #{fullF}|] 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. -- | Removes the set ghc version for the given target, if any.
@ -144,6 +145,7 @@ rmPlain :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
, MonadMask m
) )
=> Maybe Text -- ^ target => Maybe Text -- ^ target
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@ -155,11 +157,11 @@ rmPlain target = do
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt let fullF = binDir </> f <> exeExt
lift $ $(logDebug) [i|rm -f #{fullF}|] lift $ $(logDebug) [i|rm -f #{fullF}|]
liftIO $ hideError doesNotExistErrorType $ rmLink fullF lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup -- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) [i|rm -f #{hdc_file}|] 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. -- | Remove the major GHC symlink, e.g. ghc-8.6.
@ -169,6 +171,7 @@ rmMajorSymlinks :: ( MonadReader env m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m
) )
=> GHCTargetVersion => GHCTargetVersion
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@ -182,7 +185,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
let f_xy = f <> "-" <> T.unpack v' <> exeExt let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy let fullF = binDir </> f_xy
lift $ $(logDebug) [i|rm -f #{fullF}|] 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 Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir lift $ hideError doesNotExistErrorType $ rmPathForcibly dir
when (keepDirs == Never) when (keepDirs == Never)
$ liftIO $ lift
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
$ rmPath bdir $ rmPathForcibly bdir
v <- v <-
flip onException exAction flip onException exAction
$ catchAllE $ catchAllE
@ -905,7 +908,7 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es) throwE (BuildFailed bdir es)
) action ) action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir when (keepDirs == Never || keepDirs == Errors) $ lift $ rmPathForcibly bdir
pure v pure v
@ -995,13 +998,13 @@ pathIsLink = pathIsSymbolicLink
#endif #endif
rmLink :: FilePath -> IO () rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
rmLink fp = do rmLink fp = do
hideError doesNotExistErrorType . liftIO . rmFile $ fp hideError doesNotExistErrorType . rmFile $ fp
hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim") hideError doesNotExistErrorType . rmFile $ (dropExtension fp <.> "shim")
#else #else
rmLink = hideError doesNotExistErrorType . liftIO . rmFile rmLink = hideError doesNotExistErrorType . rmFile
#endif #endif
@ -1039,14 +1042,14 @@ createLink link exe = do
shimContents = "path = " <> fullLink shimContents = "path = " <> fullLink
$(logDebug) [i|rm -f #{exe}|] $(logDebug) [i|rm -f #{exe}|]
liftIO $ rmLink exe rmLink exe
$(logDebug) [i|ln -s #{fullLink} #{exe}|] $(logDebug) [i|ln -s #{fullLink} #{exe}|]
liftIO $ copyFile shimGen exe liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents liftIO $ writeFile shim shimContents
#else #else
$(logDebug) [i|rm -f #{exe}|] $(logDebug) [i|rm -f #{exe}|]
liftIO $ hideError doesNotExistErrorType $ rmFile exe hideError doesNotExistErrorType $ rmFile exe
$(logDebug) [i|ln -s #{link} #{exe}|] $(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe liftIO $ createFileLink link exe
@ -1068,7 +1071,6 @@ ensureGlobalTools :: ( MonadMask m
ensureGlobalTools = do ensureGlobalTools = do
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
(GHCupInfo _ _ gTools) <- lift getGHCupInfo (GHCupInfo _ _ gTools) <- lift getGHCupInfo
settings <- lift getSettings
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] shimDownload <- liftE $ lE @_ @'[NoDownload]
$ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
@ -1076,7 +1078,7 @@ ensureGlobalTools = do
void $ (\(DigestError _ _) -> do void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|] 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 liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl) ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure () pure ()

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

@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS) #if !defined(IS_WINDOWS)
, useXDG , useXDG
#endif #endif
, cleanupGHCupTmp
) )
where where
@ -53,9 +54,7 @@ import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Optics import Optics
#if !defined(IS_WINDOWS)
import System.Directory import System.Directory
#endif
import System.DiskSpace import System.DiskSpace
import System.Environment import System.Environment
import System.FilePath import System.FilePath
@ -262,8 +261,20 @@ parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" 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 mkGhcupTmpDir = do
#if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs
liftIO $ createTempDirectory tmpDir "ghcup"
#else
tmpdir <- liftIO getCanonicalTemporaryDirectory tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight? let minSpace = 5000 -- a rough guess, aight?
@ -281,10 +292,20 @@ mkGhcupTmpDir = do
truncate' :: Double -> Int -> Double truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n where t = 10^n
#endif
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath withGHCupTmpDir :: ( MonadReader env m
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath) , 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) <> 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 module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader
import Data.Char ( ord ) import Data.Char ( ord )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Console.Pretty import System.Console.Pretty
@ -79,17 +83,21 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
rawOutter outr rawOutter outr
initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath initGHCupFileLogging :: ( MonadReader env m
initGHCupFileLogging logsDir = do , HasDirs env
, MonadIO m
, MonadMask m
) => m FilePath
initGHCupFileLogging = do
Dirs { logsDir } <- getDirs
let logfile = logsDir </> "ghcup.log" let logfile = logsDir </> "ghcup.log"
liftIO $ do logFiles <- liftIO $ findFiles
logFiles <- findFiles logsDir
logsDir (makeRegexOpts compExtended
(makeRegexOpts compExtended execBlank
execBlank ([s|^.*\.log$|] :: B.ByteString)
([s|^.*\.log$|] :: B.ByteString) )
) forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
writeFile logfile "" liftIO $ writeFile logfile ""
pure 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 module GHCup.Utils.Prelude where
#if defined(IS_WINDOWS)
import GHCup.Types
#endif
import GHCup.Types.Optics
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Reader
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.List ( nub ) import Data.List ( nub )
@ -35,6 +40,9 @@ import Data.Word8
import Haskus.Utils.Types.List import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import System.IO.Error import System.IO.Error
#if defined(IS_WINDOWS)
import System.IO.Temp
#endif
import System.IO.Unsafe import System.IO.Unsafe
import System.Directory import System.Directory
import System.FilePath 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 as B
import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE 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/110
-- https://github.com/haskell/directory/issues/96 -- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f -- 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) rmPath :: (MonadIO m, MonadMask m)
=> FilePath => FilePath
-> m () -> m ()
rmPath fp = rmPath fp =
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10) recovering (fullJitterBackoff 25000 <> limitRetries 10)
@ -380,24 +415,46 @@ rmPath fp =
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints)) ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType)) ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
] ]
(\_ -> liftIO $ removePathForcibly fp) (\_ -> liftIO $ removeDirectory fp)
#else #else
liftIO $ removeDirectoryRecursive fp liftIO $ removeDirectory fp
#endif #endif
-- https://www.sqlite.org/src/info/89f1848d7f -- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96 -- https://github.com/haskell/directory/issues/96
rmFile :: (MonadIO m, MonadMask m) rmFile :: ( MonadIO m
, MonadMask m
, MonadReader env m
, HasDirs env
)
=> FilePath => FilePath
-> m () -> m ()
rmFile fp = rmFile fp = do
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10) Dirs { tmpDir } <- getDirs
[\_ -> Handler (\e -> pure $ isPermissionError e) liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "rmFile" "" Nothing (Just fp))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints)) tmp <- liftIO $ createTempDirectory tmpDir "rmFile"
] let dest = tmp </> takeFileName fp
(\_ -> liftIO $ removeFile 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 #else
liftIO $ removeFile fp liftIO $ removeFile fp
#endif #endif