Fix file/dir removal on windows, fixes #165
This commit is contained in:
parent
b35dbca22e
commit
1c2cf98850
GPG Key ID:
3786C5262ECB4A3F
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
71
lib/GHCup.hs
71
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user