Merge branch 'issue-165'

This commit is contained in:
Julian Ospald 2021-07-23 14:35:07 +02:00
commit 94bd01aaca
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 335 additions and 153 deletions

View File

@ -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 $ cleanupTrash)
(threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Just _ -> pure ()
@ -1418,6 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters --
-------------------------
let runInstTool' appstate' mInstPlatform =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
@ -1515,6 +1520,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runRm =
runLogger . runAppState . runE @'[NotInstalled]
let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. runAppState
@ -2063,7 +2071,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
)
pure ExitSuccess
Just uri -> do
pfreq <- runAppState getPlatformReq
s' <- appState
pfreq <- flip runReaderT s' getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
@ -2073,7 +2082,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
if clOpen
then do
s' <- appState
flip runReaderT s' $
exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@ -2085,10 +2093,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
Nuke ->
runRm (do
Nuke -> do
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s

View File

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

View File

@ -54,6 +54,9 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
#if defined(IS_WINDOWS)
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#endif
import Data.ByteString ( ByteString )
import Data.Either
import Data.List
@ -252,22 +255,6 @@ installPackedGHC :: ( MonadMask m
#endif
] m ()
installPackedGHC dl msubdir inst ver = do
#if defined(IS_WINDOWS)
lift $ $(logInfo) "Installing GHC (this may take a while)"
Dirs { tmpDir } <- lift getDirs
unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
liftIO $ rmFile unpackDir
liftE $ unpackToDir unpackDir dl
d <- case msubdir of
Just td -> liftE $ intoSubdir unpackDir td
Nothing -> pure unpackDir
liftIO $ Win32.moveFileEx d (Just inst) 0
liftIO $ rmPath unpackDir
#else
PlatformRequest {..} <- lift getPlatformReq
-- unpack
@ -283,7 +270,6 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
#endif
-- | Install an unpacked GHC distribution. This only deals with the GHC
@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
, MonadThrow m
, MonadLogger m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
)
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do
#if defined(IS_WINDOWS)
lift $ $(logInfo) "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need
-- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
Win32.moveFile source dest
setModificationTime dest mtime
#else
PlatformRequest {..} <- lift getPlatformReq
liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
copyFile source dest
setModificationTime dest mtime
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@ -312,9 +314,6 @@ installUnpackedGHC path inst ver = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
#if defined(IS_WINDOWS)
: "--enable-tarballs-autodownload"
#endif
: alpineArgs
)
(Just path)
@ -322,6 +321,7 @@ installUnpackedGHC path inst ver = do
Nothing
lEM $ make ["install"] (Just path)
pure ()
#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -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 $ recyclePathForcibly dir
v' <-
handle
@ -1319,9 +1322,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs
liftIO
$ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share")
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
@ -1346,13 +1347,13 @@ rmCabalVer ver = do
Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
lift $ hideError doesNotExistErrorType $ recycleFile (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 +1378,7 @@ rmHLSVer ver = do
Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
@ -1385,7 +1386,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 +1416,13 @@ rmStackVer ver = do
Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
lift $ hideError doesNotExistErrorType $ recycleFile (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 +1431,12 @@ rmGhcup :: ( MonadReader env m
, MonadIO m
, MonadCatch m
, MonadLogger m
, MonadMask m
, MonadUnliftIO m
)
=> m ()
rmGhcup = do
Dirs {binDir} <- getDirs
Dirs { .. } <- getDirs
let ghcupFilename = "ghcup" <> exeExt
let ghcupFilepath = binDir </> ghcupFilename
@ -1455,16 +1458,15 @@ rmGhcup = do
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
-- since it doesn't seem possible to delete a running exec in windows
-- since it doesn't seem possible to delete a running exe on windows
-- we move it to temp dir, to be deleted at next reboot
tempDir <- liftIO $ getTemporaryDirectory
let tempFilepath = tempDir </> ghcupFilename
tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
#else
-- delete it.
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
hideError doesNotExistErrorType $ rmFile ghcupFilepath
#endif
where
@ -1509,42 +1511,46 @@ rmGhcupDirs = do
, binDir
, logsDir
, cacheDir
, tmpDir
, recycleDir
} <- getDirs
let envFilePath = baseDir </> "env"
confFilePath <- getConfigFilePath
rmEnvFile envFilePath
rmConfFile confFilePath
rmDir cacheDir
rmDir logsDir
rmBinDir binDir
rmDir tmpDir
handleRm $ rmEnvFile envFilePath
handleRm $ rmConfFile confFilePath
handleRm $ rmDir cacheDir
handleRm $ rmDir logsDir
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS)
rmDir (baseDir </> "msys64")
$logInfo [i|removing #{(baseDir </> "msys64")}|]
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif
liftIO $ removeEmptyDirsRecursive baseDir
handleRm $ removeEmptyDirsRecursive baseDir
-- report files in baseDir that are left-over after
-- the standard location deletions above
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m ()
handleRm = handleIO (\e -> $logWarn [i|Part of the cleanup action failed with error: #{displayException e}
continuing regardless...|])
rmEnvFile :: (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 +1558,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 +1589,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 +1600,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 $ rmDirectory filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
if isSym
then liftIO $ deleteFile fp
then deleteFile fp
else liftIO $ ioError e
@ -2133,27 +2139,14 @@ upgradeGHCup mtarget force' = do
let fn = "ghcup" <> exeExt
p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir
#if defined(IS_WINDOWS)
let tempGhcup = cacheDir </> "ghcup.old"
liftIO $ hideError NoSuchThing $ rmFile tempGhcup
lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
-- NoSuchThing may be raised when we're updating ghcup from
-- a non-standard location
liftIO $ hideError NoSuchThing $ Win32.moveFileEx destFile (Just tempGhcup) 0
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
#else
lift $ $(logDebug) [i|rm -f #{destFile}|]
liftIO $ hideError NoSuchThing $ rmFile destFile
lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
#endif
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $

View File

@ -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 $ recycleFile 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 $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
liftIO (hideError doesNotExistErrorType $ rmFile destFile)
lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
Settings{ downloader, noNetwork } <- lift getSettings

View File

@ -384,7 +384,7 @@ data Dirs = Dirs
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
, tmpDir :: FilePath
, recycleDir :: FilePath -- mainly used on windows
}
deriving (Show, GHC.Generic)

View File

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

View File

@ -53,6 +53,7 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
@ -123,6 +124,7 @@ rmMinorSymlinks :: ( MonadReader env m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@ -134,7 +136,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 +146,7 @@ rmPlain :: ( MonadReader env m
, MonadThrow m
, MonadFail m
, MonadIO m
, MonadMask m
)
=> Maybe Text -- ^ target
-> Excepts '[NotInstalled] m ()
@ -155,11 +158,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 +172,7 @@ rmMajorSymlinks :: ( MonadReader env m
, MonadLogger m
, MonadThrow m
, MonadFail m
, MonadMask m
)
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
@ -182,7 +186,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
@ -883,7 +887,16 @@ getChangeLog dls tool (Right tag) =
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: (Pretty (V e), Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
runBuildAction :: ( Pretty (V e)
, Show (V e)
, MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, MonadLogger m
, MonadUnliftIO m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
@ -892,11 +905,9 @@ runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
liftIO $ hideError doesNotExistErrorType $ rmPath dir
lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never)
$ liftIO
$ hideError doesNotExistErrorType
$ rmPath bdir
$ lift $ rmBDir bdir
v <-
flip onException exAction
$ catchAllE
@ -905,10 +916,20 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn)
[i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
$ hideError doesNotExistErrorType
$ rmPathForcibly dir)
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
@ -995,13 +1016,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 . recycleFile $ fp
hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else
rmLink = hideError doesNotExistErrorType . liftIO . rmFile
rmLink = hideError doesNotExistErrorType . recycleFile
#endif
@ -1039,14 +1060,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 $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
@ -1068,7 +1089,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 +1096,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 $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
@ -1087,14 +1107,14 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
createDirRecursive' tmpDir
createDirRecursive' trashDir
pure ()
@ -1108,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)

View File

@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS)
, useXDG
#endif
, cleanupTrash
)
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
@ -191,12 +190,10 @@ ghcupLogsDir = do
#endif
-- | Defaults to '~/.ghcup/tmp.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
@ -207,7 +204,7 @@ getAllDirs = do
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir
recycleDir <- ghcupRecycleDir
pure Dirs { .. }
@ -262,7 +259,15 @@ 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
tmpdir <- liftIO getCanonicalTemporaryDirectory
@ -283,8 +288,25 @@ mkGhcupTmpDir = do
where t = 10^n
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)
(\fp ->
handleIO (\e -> run
$ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
. rmPathForcibly
$ fp))
@ -312,3 +334,21 @@ relativeSymlink p1 p2 =
<> joinPath ([pathSeparator] : drop (length common) d2)
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadLogger m
, MonadReader env m
, HasDirs env
)
=> m ()
cleanupTrash = do
Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory recycleDir
if null contents
then pure ()
else do
$(logWarn) [i|Removing leftover files in #{recycleDir}|]
forM_ contents (\fp -> handleIO (\e ->
$(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
) $ liftIO $ removePathForcibly (recycleDir </> fp))

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
logFiles <- liftIO $ findFiles
logsDir
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
writeFile logfile ""
liftIO $ writeFile logfile ""
pure logfile

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
@ -312,17 +323,16 @@ createDirRecursive' p =
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
copyDirectoryRecursive srcDir destDir = do
copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f)
copyFilesWith destDir [ (srcDir, f)
| f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ())
-> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy targetDir srcFiles = do
copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@ -367,34 +377,101 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
ignore ['.', '.'] = True
ignore _ = False
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
rmPath :: (MonadIO m, MonadMask m)
recyclePathForcibly :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadMask m
)
=> FilePath
-> m ()
rmPath fp =
recyclePathForcibly fp = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removePathForcibly fp
#endif
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
rmPathForcibly fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removePathForcibly fp)
#else
liftIO $ removePathForcibly fp
#endif
rmDirectory :: (MonadIO m, MonadMask m)
=> FilePath
-> m ()
rmDirectory fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> 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)
recycleFile :: ( MonadIO m
, MonadMask m
, MonadReader env m
, HasDirs env
)
=> FilePath
-> m ()
recycleFile fp = do
#if defined(IS_WINDOWS)
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
liftIO (Win32.moveFileEx fp (Just dest) 0)
`catch`
(\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
`finally`
(liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
#else
liftIO $ removeFile fp
#endif
rmFile :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
rmFile fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeFile fp)
@ -403,6 +480,34 @@ rmFile fp =
#endif
rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
=> FilePath
-> m ()
rmDirectoryLink fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removeDirectoryLink fp)
#else
liftIO $ removeDirectoryLink fp
#endif
#if defined(IS_WINDOWS)
recover :: (MonadIO m, MonadMask m) => m a -> m a
recover action =
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> action)
#endif
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)