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

Merge branch 'issue-165'

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

145
lib/GHCup.hs
View File

@ -54,6 +54,9 @@ import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
#if defined(IS_WINDOWS)
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#endif
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.List import Data.List
@ -252,22 +255,6 @@ installPackedGHC :: ( MonadMask m
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver = do 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 PlatformRequest {..} <- lift getPlatformReq
-- unpack -- unpack
@ -283,7 +270,6 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack liftE $ runBuildAction tmpUnpack
(Just inst) (Just inst)
(installUnpackedGHC workdir inst ver) (installUnpackedGHC workdir inst ver)
#endif
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m
, MonadMask m
) )
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do 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 PlatformRequest {..} <- lift getPlatformReq
liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
copyFile source dest
setModificationTime dest mtime
let alpineArgs let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform | 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)" lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst) ("./configure" : ("--prefix=" <> inst)
#if defined(IS_WINDOWS)
: "--enable-tarballs-autodownload"
#endif
: alpineArgs : alpineArgs
) )
(Just path) (Just path)
@ -322,6 +321,7 @@ installUnpackedGHC path inst ver = do
Nothing Nothing
lEM $ make ["install"] (Just path) lEM $ make ["install"] (Just path)
pure () pure ()
#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -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 $ recyclePathForcibly dir
v' <- v' <-
handle handle
@ -1319,9 +1322,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
liftIO lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
$ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@ -1346,13 +1347,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 $ recycleFile (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 +1378,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 $ recycleFile (binDir </> f)
when (Just ver == isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- delete all set symlinks -- delete all set symlinks
@ -1385,7 +1386,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 +1416,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 $ recycleFile (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 +1431,12 @@ rmGhcup :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadMask m
, MonadUnliftIO 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
@ -1455,16 +1458,15 @@ rmGhcup = do
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#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 exe on 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 tempFilepath <- mkGhcupTmpDir
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 </> "ghcup")) 0
#else #else
-- delete it. -- delete it.
hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath hideError doesNotExistErrorType $ rmFile ghcupFilepath
#endif #endif
where where
@ -1509,42 +1511,46 @@ rmGhcupDirs = do
, binDir , binDir
, logsDir , logsDir
, cacheDir , cacheDir
, tmpDir , recycleDir
} <- getDirs } <- getDirs
let envFilePath = baseDir </> "env" let envFilePath = baseDir </> "env"
confFilePath <- getConfigFilePath confFilePath <- getConfigFilePath
rmEnvFile envFilePath handleRm $ rmEnvFile envFilePath
rmConfFile confFilePath handleRm $ rmConfFile confFilePath
rmDir cacheDir handleRm $ rmDir cacheDir
rmDir logsDir handleRm $ rmDir logsDir
rmBinDir binDir handleRm $ rmBinDir binDir
rmDir tmpDir handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
rmDir (baseDir </> "msys64") $logInfo [i|removing #{(baseDir </> "msys64")}|]
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif #endif
liftIO $ removeEmptyDirsRecursive baseDir handleRm $ 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
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where 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 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 +1558,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 +1589,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 +1600,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 $ rmDirectory 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
@ -2133,27 +2139,14 @@ upgradeGHCup mtarget force' = do
let fn = "ghcup" <> exeExt let fn = "ghcup" <> exeExt
p <- liftE $ download dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|] lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' 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}|] lift $ $(logDebug) [i|rm -f #{destFile}|]
liftIO $ hideError NoSuchThing $ rmFile destFile lift $ hideError NoSuchThing $ recycleFile 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
#endif
lift $ chmod_755 destFile lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $ liftIO (isInPath destFile) >>= \b -> unless b $

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

2
lib/GHCup/Types.hs
View File

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

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)

63
lib/GHCup/Utils.hs
View File

@ -53,6 +53,7 @@ import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
import Data.Bits import Data.Bits
#endif #endif
@ -123,6 +124,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 +136,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 +146,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 +158,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 +172,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 +186,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
@ -883,8 +887,17 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 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)
=> FilePath -- ^ build directory (cleaned up depending on Settings) , 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 -> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
@ -892,11 +905,9 @@ 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 $ recyclePathForcibly dir
when (keepDirs == Never) when (keepDirs == Never)
$ liftIO $ lift $ rmBDir bdir
$ hideError doesNotExistErrorType
$ rmPath bdir
v <- v <-
flip onException exAction flip onException exAction
$ catchAllE $ catchAllE
@ -905,10 +916,20 @@ 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 $ rmBDir bdir
pure v 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 getVersionInfo :: Version
-> Tool -> Tool
-> GHCupDownloads -> GHCupDownloads
@ -995,13 +1016,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 . recycleFile $ fp
hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim") hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else #else
rmLink = hideError doesNotExistErrorType . liftIO . rmFile rmLink = hideError doesNotExistErrorType . recycleFile
#endif #endif
@ -1039,14 +1060,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 $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|] $(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe liftIO $ createFileLink link exe
@ -1068,7 +1089,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 +1096,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 $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl) ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure () pure ()
@ -1087,14 +1107,14 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO () 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
createDirRecursive' (baseDir </> "ghc") createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir createDirRecursive' binDir
createDirRecursive' cacheDir createDirRecursive' cacheDir
createDirRecursive' logsDir createDirRecursive' logsDir
createDirRecursive' confDir createDirRecursive' confDir
createDirRecursive' tmpDir createDirRecursive' trashDir
pure () pure ()
@ -1108,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ghcBinaryName :: GHCTargetVersion -> String ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt) 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) ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)

74
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
, cleanupTrash
) )
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
@ -191,23 +190,21 @@ ghcupLogsDir = do
#endif #endif
-- | Defaults to '~/.ghcup/tmp. -- | '~/.ghcup/trash'.
-- -- Mainly used on windows to improve file removal operations
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), ghcupRecycleDir :: IO FilePath
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec. ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
getAllDirs :: IO Dirs getAllDirs :: IO Dirs
getAllDirs = do getAllDirs = do
baseDir <- ghcupBaseDir baseDir <- ghcupBaseDir
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir recycleDir <- ghcupRecycleDir
pure Dirs { .. } pure Dirs { .. }
@ -262,7 +259,15 @@ 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
tmpdir <- liftIO getCanonicalTemporaryDirectory tmpdir <- liftIO getCanonicalTemporaryDirectory
@ -283,8 +288,25 @@ mkGhcupTmpDir = do
where t = 10^n where t = 10^n
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)
(\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) <> 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))

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 . recycleFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
writeFile logfile "" liftIO $ writeFile logfile ""
pure logfile pure logfile

135
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
@ -312,17 +323,16 @@ createDirRecursive' p =
-- | Recursively copy the contents of one directory to another path. -- | Recursively copy the contents of one directory to another path.
-- --
-- This is a rip-off of Cabal library. -- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO () copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive srcDir destDir = do copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f) copyFilesWith destDir [ (srcDir, f)
| f <- srcFiles ] | f <- srcFiles ]
where where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ()) copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
-> FilePath -> [(FilePath, FilePath)] -> IO () copyFilesWith targetDir srcFiles = do
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything -- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@ -367,34 +377,101 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
ignore ['.', '.'] = True ignore ['.', '.'] = True
ignore _ = False ignore _ = False
-- 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
rmPath :: (MonadIO m, MonadMask m) recyclePathForcibly :: ( MonadIO m
=> FilePath , MonadReader env m
-> m () , HasDirs env
rmPath fp = , MonadMask m
)
=> FilePath
-> m ()
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) #if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10) recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e) [\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> 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) 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 => FilePath
-> m () -> m ()
rmFile fp = rmFile fp =
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10) recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e) [\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints)) ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
] ]
(\_ -> liftIO $ removeFile fp) (\_ -> liftIO $ removeFile fp)
@ -403,6 +480,34 @@ rmFile fp =
#endif #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 -- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty) traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)