Use strongly types GHCupPath and restrict destructive operations
This commit is contained in:
parent
fa924eac15
commit
c9790e5823
GPG Key ID:
3786C5262ECB4A3F
@ -44,7 +44,6 @@ import Data.Vector ( Vector
|
|||||||
import Data.Versions hiding ( str )
|
import Data.Versions hiding ( str )
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Prelude hiding ( appendFile )
|
import Prelude hiding ( appendFile )
|
||||||
import System.Directory ( canonicalizePath )
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
|
|||||||
@ -52,7 +52,6 @@ import Haskus.Utils.Variant.Excepts
|
|||||||
import Options.Applicative hiding ( style )
|
import Options.Applicative hiding ( style )
|
||||||
import Prelude hiding ( appendFile )
|
import Prelude hiding ( appendFile )
|
||||||
import Safe
|
import Safe
|
||||||
import System.Directory
|
|
||||||
import System.Process ( readProcess )
|
import System.Process ( readProcess )
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Text.HTML.TagSoup hiding ( Tag )
|
import Text.HTML.TagSoup hiding ( Tag )
|
||||||
|
|||||||
@ -494,7 +494,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
|
|||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> runLogger $ logError $ T.pack $ prettyShow err
|
Never -> runLogger $ logError $ T.pack $ prettyShow err
|
||||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||||
"Check the logs at " <> T.pack logsDir <> " and the build directory "
|
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
|
||||||
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 9
|
pure $ ExitFailure 9
|
||||||
@ -553,7 +553,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
|
|||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> runLogger $ logError $ T.pack $ prettyShow err
|
Never -> runLogger $ logError $ T.pack $ prettyShow err
|
||||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||||
"Check the logs at " <> T.pack logsDir <> " and the build directory "
|
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory "
|
||||||
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
<> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 9
|
pure $ ExitFailure 9
|
||||||
|
|||||||
@ -18,6 +18,7 @@ import GHCup.OptParse.Common
|
|||||||
import GHCup
|
import GHCup
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
import GHCup.Utils.Dirs
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
|
|
||||||
@ -446,21 +447,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
||||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||||
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 3
|
pure $ ExitFailure 3
|
||||||
VLeft err@(V (BuildFailed tmpdir _, ())) -> do
|
VLeft err@(V (BuildFailed tmpdir _, ())) -> do
|
||||||
case keepDirs settings of
|
case keepDirs settings of
|
||||||
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
Never -> runLogger (logError $ T.pack $ prettyShow err)
|
||||||
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
_ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
|
||||||
"Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
"Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
|
||||||
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
|
||||||
pure $ ExitFailure 3
|
pure $ ExitFailure 3
|
||||||
|
|
||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
logError $ T.pack $ prettyShow e
|
logError $ T.pack $ prettyShow e
|
||||||
logError $ "Also check the logs in " <> T.pack logsDir
|
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||||
pure $ ExitFailure 3
|
pure $ ExitFailure 3
|
||||||
|
|
||||||
|
|
||||||
@ -512,7 +513,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
logError $ T.pack $ prettyShow e
|
logError $ T.pack $ prettyShow e
|
||||||
logError $ "Also check the logs in " <> T.pack logsDir
|
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
installHLS :: InstallOptions -> IO ExitCode
|
installHLS :: InstallOptions -> IO ExitCode
|
||||||
@ -572,7 +573,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
logError $ T.pack $ prettyShow e
|
logError $ T.pack $ prettyShow e
|
||||||
logError $ "Also check the logs in " <> T.pack logsDir
|
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
installStack :: InstallOptions -> IO ExitCode
|
installStack :: InstallOptions -> IO ExitCode
|
||||||
@ -623,6 +624,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
VLeft e -> do
|
VLeft e -> do
|
||||||
runLogger $ do
|
runLogger $ do
|
||||||
logError $ T.pack $ prettyShow e
|
logError $ T.pack $ prettyShow e
|
||||||
logError $ "Also check the logs in " <> T.pack logsDir
|
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
|
||||||
pure $ ExitFailure 4
|
pure $ ExitFailure 4
|
||||||
|
|
||||||
|
|||||||
@ -32,7 +32,6 @@ import Data.List ( intercalate )
|
|||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Options.Applicative hiding ( style )
|
import Options.Applicative hiding ( style )
|
||||||
import Prelude hiding ( appendFile )
|
import Prelude hiding ( appendFile )
|
||||||
import System.Directory
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
|||||||
@ -17,6 +17,7 @@ import GHCup
|
|||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.OptParse.Common
|
import GHCup.OptParse.Common
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
|
import GHCup.Utils
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
|
|
||||||
@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
|||||||
pure $ ExitFailure 30
|
pure $ ExitFailure 30
|
||||||
|
|
||||||
(WhereisBaseDir, _) -> do
|
(WhereisBaseDir, _) -> do
|
||||||
liftIO $ putStr baseDir
|
liftIO $ putStr $ fromGHCupPath baseDir
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
(WhereisBinDir, _) -> do
|
(WhereisBinDir, _) -> do
|
||||||
@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
|||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
(WhereisCacheDir, _) -> do
|
(WhereisCacheDir, _) -> do
|
||||||
liftIO $ putStr cacheDir
|
liftIO $ putStr $ fromGHCupPath cacheDir
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
(WhereisLogsDir, _) -> do
|
(WhereisLogsDir, _) -> do
|
||||||
liftIO $ putStr logsDir
|
liftIO $ putStr $ fromGHCupPath logsDir
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
(WhereisConfDir, _) -> do
|
(WhereisConfDir, _) -> do
|
||||||
liftIO $ putStr confDir
|
liftIO $ putStr $ fromGHCupPath confDir
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|||||||
@ -220,7 +220,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
|||||||
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
|
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
|
||||||
|
|
||||||
race_ (liftIO $ runReaderT cleanupTrash s')
|
race_ (liftIO $ runReaderT cleanupTrash s')
|
||||||
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
|
(threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually"))
|
||||||
|
|
||||||
case optCommand of
|
case optCommand of
|
||||||
Nuke -> pure ()
|
Nuke -> pure ()
|
||||||
|
|||||||
192
lib/GHCup.hs
192
lib/GHCup.hs
@ -77,11 +77,9 @@ import Prelude hiding ( abs
|
|||||||
, writeFile
|
, writeFile
|
||||||
)
|
)
|
||||||
import Safe hiding ( at )
|
import Safe hiding ( at )
|
||||||
import System.Directory hiding ( findFiles, copyFile )
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.IO.Temp
|
|
||||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
@ -293,8 +291,8 @@ installPackedGHC dl msubdir inst ver forceInstall = do
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
|
|
||||||
-- the subdir of the archive where we do the work
|
-- the subdir of the archive where we do the work
|
||||||
workdir <- maybe (pure tmpUnpack)
|
workdir <- maybe (pure tmpUnpack)
|
||||||
@ -319,7 +317,7 @@ installUnpackedGHC :: ( MonadReader env m
|
|||||||
, MonadResource m
|
, MonadResource m
|
||||||
, MonadFail m
|
, MonadFail m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
|
||||||
-> InstallDirResolved -- ^ Path to install to
|
-> InstallDirResolved -- ^ Path to install to
|
||||||
-> Version -- ^ The GHC version
|
-> Version -- ^ The GHC version
|
||||||
-> Bool -- ^ Force install
|
-> Bool -- ^ Force install
|
||||||
@ -351,13 +349,13 @@ installUnpackedGHC path inst ver forceInstall
|
|||||||
("./configure" : ("--prefix=" <> fromInstallDir inst)
|
("./configure" : ("--prefix=" <> fromInstallDir inst)
|
||||||
: alpineArgs
|
: alpineArgs
|
||||||
)
|
)
|
||||||
(Just path)
|
(Just $ fromGHCupPath path)
|
||||||
"ghc-configure"
|
"ghc-configure"
|
||||||
Nothing
|
Nothing
|
||||||
tmpInstallDest <- lift withGHCupTmpDir
|
tmpInstallDest <- lift withGHCupTmpDir
|
||||||
lEM $ make ["DESTDIR=" <> tmpInstallDest, "install"] (Just path)
|
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)
|
||||||
lift $ logInfo $ "Merging file tree from \"" <> T.pack tmpInstallDest <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
|
lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
|
||||||
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
|
fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
|
||||||
(fromInstallDir inst)
|
(fromInstallDir inst)
|
||||||
(\f t -> liftIO (install f t (not forceInstall)))
|
(\f t -> liftIO (install f t (not forceInstall)))
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
|
||||||
@ -472,11 +470,11 @@ installCabalBindist dlinfo ver installDir forceInstall = do
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
|
|
||||||
-- the subdir of the archive where we do the work
|
-- the subdir of the archive where we do the work
|
||||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||||
|
|
||||||
case installDir of
|
case installDir of
|
||||||
IsolateDir isoDir -> do -- isolated install
|
IsolateDir isoDir -> do -- isolated install
|
||||||
@ -484,7 +482,7 @@ installCabalBindist dlinfo ver installDir forceInstall = do
|
|||||||
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||||
|
|
||||||
GHCupInternal -> do -- regular install
|
GHCupInternal -> do -- regular install
|
||||||
liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall
|
liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall
|
||||||
|
|
||||||
|
|
||||||
-- | Install an unpacked cabal distribution.Symbol
|
-- | Install an unpacked cabal distribution.Symbol
|
||||||
@ -501,7 +499,7 @@ installCabalUnpacked path inst ver forceInstall = do
|
|||||||
let destFileName = cabalFile
|
let destFileName = cabalFile
|
||||||
<> (case inst of
|
<> (case inst of
|
||||||
IsolateDirResolved _ -> ""
|
IsolateDirResolved _ -> ""
|
||||||
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
|
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||||
)
|
)
|
||||||
<> exeExt
|
<> exeExt
|
||||||
let destPath = fromInstallDir inst </> destFileName
|
let destPath = fromInstallDir inst </> destFileName
|
||||||
@ -614,11 +612,11 @@ installHLSBindist dlinfo ver installDir forceInstall = do
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
|
|
||||||
-- the subdir of the archive where we do the work
|
-- the subdir of the archive where we do the work
|
||||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||||
legacy <- liftIO $ isLegacyHLSBindist workdir
|
legacy <- liftIO $ isLegacyHLSBindist workdir
|
||||||
|
|
||||||
if
|
if
|
||||||
@ -636,7 +634,7 @@ installHLSBindist dlinfo ver installDir forceInstall = do
|
|||||||
|
|
||||||
GHCupInternal -> do
|
GHCupInternal -> do
|
||||||
if legacy
|
if legacy
|
||||||
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
|
then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall
|
||||||
else do
|
else do
|
||||||
inst <- ghcupHLSDir ver
|
inst <- ghcupHLSDir ver
|
||||||
liftE $ runBuildAction tmpUnpack
|
liftE $ runBuildAction tmpUnpack
|
||||||
@ -671,8 +669,8 @@ installHLSUnpacked path inst ver forceInstall = do
|
|||||||
PlatformRequest { .. } <- lift getPlatformReq
|
PlatformRequest { .. } <- lift getPlatformReq
|
||||||
lift $ logInfo "Installing HLS"
|
lift $ logInfo "Installing HLS"
|
||||||
tmpInstallDest <- lift withGHCupTmpDir
|
tmpInstallDest <- lift withGHCupTmpDir
|
||||||
lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
|
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
|
||||||
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
|
fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
|
||||||
(fromInstallDir inst)
|
(fromInstallDir inst)
|
||||||
(\f t -> liftIO (install f t (not forceInstall)))
|
(\f t -> liftIO (install f t (not forceInstall)))
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
|
||||||
@ -702,7 +700,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
|
|||||||
let toF = dropSuffix exeExt f
|
let toF = dropSuffix exeExt f
|
||||||
<> (case installDir of
|
<> (case installDir of
|
||||||
IsolateDirResolved _ -> ""
|
IsolateDirResolved _ -> ""
|
||||||
GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver
|
_ -> ("~" <>) . T.unpack . prettyVer $ ver
|
||||||
)
|
)
|
||||||
<> exeExt
|
<> exeExt
|
||||||
|
|
||||||
@ -720,7 +718,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
|
|||||||
toF = wrapper
|
toF = wrapper
|
||||||
<> (case installDir of
|
<> (case installDir of
|
||||||
IsolateDirResolved _ -> ""
|
IsolateDirResolved _ -> ""
|
||||||
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
|
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||||
)
|
)
|
||||||
<> exeExt
|
<> exeExt
|
||||||
srcWrapperPath = path </> wrapper <> exeExt
|
srcWrapperPath = path </> wrapper <> exeExt
|
||||||
@ -827,8 +825,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
|
|
||||||
workdir <- maybe (pure tmpUnpack)
|
workdir <- maybe (pure tmpUnpack)
|
||||||
(liftE . intoSubdir tmpUnpack)
|
(liftE . intoSubdir tmpUnpack)
|
||||||
@ -839,7 +837,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
-- clone from git
|
-- clone from git
|
||||||
Right GitBranch{..} -> do
|
Right GitBranch{..} -> do
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
||||||
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
|
||||||
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
|
let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
|
||||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||||
@ -859,7 +857,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
lEM $ git fetch_args
|
lEM $ git fetch_args
|
||||||
|
|
||||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
||||||
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack </> "haskell-language-server.cabal"))
|
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
|
||||||
pure . (\c -> Version Nothing c [] Nothing)
|
pure . (\c -> Version Nothing c [] Nothing)
|
||||||
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
|
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
|
||||||
. versionNumbers
|
. versionNumbers
|
||||||
@ -868,7 +866,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
. packageDescription
|
. packageDescription
|
||||||
$ gpd
|
$ gpd
|
||||||
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
|
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
|
||||||
|
|
||||||
pure (tmpUnpack, tver)
|
pure (tmpUnpack, tver)
|
||||||
@ -879,30 +877,30 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
|
|
||||||
liftE $ runBuildAction
|
liftE $ runBuildAction
|
||||||
workdir
|
workdir
|
||||||
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
|
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
|
||||||
let tmpInstallDir = workdir </> "out"
|
let tmpInstallDir = fromGHCupPath workdir </> "out"
|
||||||
liftIO $ createDirRecursive' tmpInstallDir
|
liftIO $ createDirRecursive' tmpInstallDir
|
||||||
|
|
||||||
-- apply patches
|
-- apply patches
|
||||||
liftE $ applyAnyPatch patches workdir
|
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
|
||||||
|
|
||||||
-- set up project files
|
-- set up project files
|
||||||
cp <- case cabalProject of
|
cp <- case cabalProject of
|
||||||
Just (Left cp)
|
Just (Left cp)
|
||||||
| isAbsolute cp -> do
|
| isAbsolute cp -> do
|
||||||
copyFileE cp (workdir </> "cabal.project") False
|
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
|
||||||
pure "cabal.project"
|
pure "cabal.project"
|
||||||
| otherwise -> pure (takeFileName cp)
|
| otherwise -> pure (takeFileName cp)
|
||||||
Just (Right uri) -> do
|
Just (Right uri) -> do
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
|
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False
|
||||||
copyFileE cp (workdir </> "cabal.project") False
|
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
|
||||||
pure "cabal.project"
|
pure "cabal.project"
|
||||||
Nothing -> pure "cabal.project"
|
Nothing -> pure "cabal.project"
|
||||||
forM_ cabalProjectLocal $ \uri -> do
|
forM_ cabalProjectLocal $ \uri -> do
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
|
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False
|
||||||
copyFileE cpl (workdir </> cp <.> "local") False
|
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
|
||||||
artifacts <- forM (sort ghcs) $ \ghc -> do
|
artifacts <- forM (sort ghcs) $ \ghc -> do
|
||||||
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
|
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
|
||||||
liftIO $ createDirRecursive' tmpInstallDir
|
liftIO $ createDirRecursive' tmpInstallDir
|
||||||
@ -923,7 +921,9 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
"exe:haskell-language-server"
|
"exe:haskell-language-server"
|
||||||
, "exe:haskell-language-server-wrapper"]
|
, "exe:haskell-language-server-wrapper"]
|
||||||
)
|
)
|
||||||
(Just workdir) "cabal" Nothing
|
(Just $ fromGHCupPath workdir)
|
||||||
|
"cabal"
|
||||||
|
Nothing
|
||||||
pure ghcInstallDir
|
pure ghcInstallDir
|
||||||
|
|
||||||
forM_ artifacts $ \artifact -> do
|
forM_ artifacts $ \artifact -> do
|
||||||
@ -931,14 +931,14 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
|
|||||||
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
|
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
|
||||||
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
|
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
|
||||||
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
|
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
|
||||||
liftIO $ rmPathForcibly artifact
|
liftIO $ hideError NoSuchThing $ rmFile artifact
|
||||||
|
|
||||||
case installDir of
|
case installDir of
|
||||||
IsolateDir isoDir -> do
|
IsolateDir isoDir -> do
|
||||||
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
|
||||||
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
|
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
|
||||||
GHCupInternal -> do
|
GHCupInternal -> do
|
||||||
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True
|
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True
|
||||||
)
|
)
|
||||||
|
|
||||||
pure installVer
|
pure installVer
|
||||||
@ -1044,8 +1044,8 @@ installStackBindist dlinfo ver installDir forceInstall = do
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- lift withGHCupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
|
|
||||||
-- the subdir of the archive where we do the work
|
-- the subdir of the archive where we do the work
|
||||||
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
|
||||||
@ -1055,12 +1055,12 @@ installStackBindist dlinfo ver installDir forceInstall = do
|
|||||||
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
|
lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
|
||||||
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
|
||||||
GHCupInternal -> do -- regular install
|
GHCupInternal -> do -- regular install
|
||||||
liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall
|
liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall
|
||||||
|
|
||||||
|
|
||||||
-- | Install an unpacked stack distribution.
|
-- | Install an unpacked stack distribution.
|
||||||
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
|
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
|
||||||
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
=> GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||||
-> InstallDirResolved
|
-> InstallDirResolved
|
||||||
-> Version
|
-> Version
|
||||||
-> Bool -- ^ Force install
|
-> Bool -- ^ Force install
|
||||||
@ -1072,13 +1072,13 @@ installStackUnpacked path installDir ver forceInstall = do
|
|||||||
let destFileName = stackFile
|
let destFileName = stackFile
|
||||||
<> (case installDir of
|
<> (case installDir of
|
||||||
IsolateDirResolved _ -> ""
|
IsolateDirResolved _ -> ""
|
||||||
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
|
_ -> ("-" <>) . T.unpack . prettyVer $ ver
|
||||||
)
|
)
|
||||||
<> exeExt
|
<> exeExt
|
||||||
destPath = fromInstallDir installDir </> destFileName
|
destPath = fromInstallDir installDir </> destFileName
|
||||||
|
|
||||||
copyFileE
|
copyFileE
|
||||||
(path </> stackFile <> exeExt)
|
(fromGHCupPath path </> stackFile <> exeExt)
|
||||||
destPath
|
destPath
|
||||||
(not forceInstall)
|
(not forceInstall)
|
||||||
lift $ chmod_755 destPath
|
lift $ chmod_755 destPath
|
||||||
@ -1160,7 +1160,7 @@ setGHC ver sghc mBinDir = do
|
|||||||
|
|
||||||
when (isNothing mBinDir) $ do
|
when (isNothing mBinDir) $ do
|
||||||
-- create symlink for share dir
|
-- create symlink for share dir
|
||||||
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
|
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS
|
||||||
|
|
||||||
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
|
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
|
||||||
|
|
||||||
@ -1180,7 +1180,7 @@ setGHC ver sghc mBinDir = do
|
|||||||
-> m ()
|
-> m ()
|
||||||
symlinkShareDir ghcdir ver' = do
|
symlinkShareDir ghcdir ver' = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
let destdir = baseDir
|
let destdir = fromGHCupPath baseDir
|
||||||
case sghc of
|
case sghc of
|
||||||
SetGHCOnly -> do
|
SetGHCOnly -> do
|
||||||
let sharedir = "share"
|
let sharedir = "share"
|
||||||
@ -1799,19 +1799,20 @@ rmGHCVer ver = do
|
|||||||
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
|
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
|
||||||
-- then fix them (e.g. with an earlier version)
|
-- then fix them (e.g. with an earlier version)
|
||||||
|
|
||||||
dir <- lift $ ghcupGHCDir ver
|
dir' <- lift $ ghcupGHCDir ver
|
||||||
|
let dir = fromGHCupPath dir'
|
||||||
lift (getInstalledFiles GHC ver) >>= \case
|
lift (getInstalledFiles GHC ver) >>= \case
|
||||||
Just files -> do
|
Just files -> do
|
||||||
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
|
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
|
||||||
forM_ files (liftIO . deleteFile . (\f -> dir </> dropDrive f))
|
forM_ files (liftIO . deleteFile . (\f -> dir </> dropDrive f))
|
||||||
f <- recordedInstallationFile GHC ver
|
f <- recordedInstallationFile GHC ver
|
||||||
liftIO $ deleteFile f
|
liftIO $ hideError doesNotExistErrorType $ deleteFile f
|
||||||
removeEmptyDirsRecursive dir
|
removeEmptyDirsRecursive dir
|
||||||
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
|
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
|
||||||
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
|
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
|
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
|
||||||
lift $ recyclePathForcibly dir
|
lift $ recyclePathForcibly dir'
|
||||||
|
|
||||||
v' <-
|
v' <-
|
||||||
handle
|
handle
|
||||||
@ -1823,7 +1824,7 @@ rmGHCVer ver = do
|
|||||||
|
|
||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
|
|
||||||
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
|
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")
|
||||||
|
|
||||||
|
|
||||||
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
|
||||||
@ -1882,7 +1883,8 @@ rmHLSVer ver = do
|
|||||||
-- delete all set symlinks
|
-- delete all set symlinks
|
||||||
liftE rmPlainHLS
|
liftE rmPlainHLS
|
||||||
|
|
||||||
hlsDir <- ghcupHLSDir ver
|
hlsDir' <- ghcupHLSDir ver
|
||||||
|
let hlsDir = fromGHCupPath hlsDir'
|
||||||
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
|
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
|
||||||
Just files -> do
|
Just files -> do
|
||||||
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
|
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
|
||||||
@ -1894,7 +1896,7 @@ rmHLSVer ver = do
|
|||||||
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
|
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
|
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
|
||||||
recyclePathForcibly hlsDir
|
recyclePathForcibly hlsDir'
|
||||||
|
|
||||||
when (Just ver == isHlsSet) $ do
|
when (Just ver == isHlsSet) $ do
|
||||||
-- set latest hls
|
-- set latest hls
|
||||||
@ -1974,7 +1976,7 @@ rmGhcup = do
|
|||||||
tempFilepath <- mkGhcupTmpDir
|
tempFilepath <- mkGhcupTmpDir
|
||||||
hideError UnsupportedOperation $
|
hideError UnsupportedOperation $
|
||||||
liftIO $ hideError NoSuchThing $
|
liftIO $ hideError NoSuchThing $
|
||||||
moveFile ghcupFilepath (tempFilepath </> "ghcup")
|
moveFile ghcupFilepath (fromGHCupPath tempFilepath </> "ghcup")
|
||||||
else
|
else
|
||||||
-- delete it.
|
-- delete it.
|
||||||
hideError doesNotExistErrorType $ rmFile ghcupFilepath
|
hideError doesNotExistErrorType $ rmFile ghcupFilepath
|
||||||
@ -2024,7 +2026,7 @@ rmGhcupDirs = do
|
|||||||
, recycleDir
|
, recycleDir
|
||||||
} <- getDirs
|
} <- getDirs
|
||||||
|
|
||||||
let envFilePath = baseDir </> "env"
|
let envFilePath = fromGHCupPath baseDir </> "env"
|
||||||
|
|
||||||
confFilePath <- getConfigFilePath
|
confFilePath <- getConfigFilePath
|
||||||
|
|
||||||
@ -2038,14 +2040,14 @@ rmGhcupDirs = do
|
|||||||
handleRm $ rmBinDir binDir
|
handleRm $ rmBinDir binDir
|
||||||
handleRm $ rmDir recycleDir
|
handleRm $ rmDir recycleDir
|
||||||
when isWindows $ do
|
when isWindows $ do
|
||||||
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
|
logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")
|
||||||
handleRm $ rmPathForcibly (baseDir </> "msys64")
|
handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")
|
||||||
|
|
||||||
handleRm $ removeEmptyDirsRecursive baseDir
|
handleRm $ removeEmptyDirsRecursive (fromGHCupPath 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 (fromGHCupPath baseDir)
|
||||||
|
|
||||||
where
|
where
|
||||||
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
|
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
|
||||||
@ -2062,15 +2064,15 @@ rmGhcupDirs = do
|
|||||||
logInfo "removing Ghcup Config File"
|
logInfo "removing Ghcup Config File"
|
||||||
hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath
|
hideErrorDef [permissionErrorType] () $ deleteFile' confFilePath
|
||||||
|
|
||||||
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => GHCupPath -> 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,
|
||||||
-- althought 'deleteFile' should already handle it.
|
-- althought 'deleteFile' should already handle it.
|
||||||
hideErrorDef [doesNotExistErrorType] () $ do
|
hideErrorDef [doesNotExistErrorType] () $ do
|
||||||
logInfo $ "removing " <> T.pack dir
|
logInfo $ "removing " <> T.pack (fromGHCupPath dir)
|
||||||
contents <- liftIO $ getDirectoryContentsRecursive dir
|
contents <- liftIO $ getDirectoryContentsRecursive dir
|
||||||
forM_ contents (deleteFile' . (dir </>))
|
forM_ contents (deleteFile' . (fromGHCupPath dir </>))
|
||||||
|
|
||||||
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||||
rmBinDir binDir
|
rmBinDir binDir
|
||||||
@ -2085,7 +2087,7 @@ rmGhcupDirs = do
|
|||||||
reportRemainingFiles dir = do
|
reportRemainingFiles dir = do
|
||||||
-- force the files so the errors don't leak
|
-- force the files so the errors don't leak
|
||||||
(force -> !remainingFiles) <- liftIO
|
(force -> !remainingFiles) <- liftIO
|
||||||
(getDirectoryContentsRecursive dir >>= evaluate)
|
(getDirectoryContentsRecursiveUnsafe dir >>= evaluate)
|
||||||
let normalizedFilePaths = fmap normalise remainingFiles
|
let normalizedFilePaths = fmap normalise remainingFiles
|
||||||
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
|
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
|
||||||
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
|
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
|
||||||
@ -2113,7 +2115,7 @@ removeDirIfEmptyOrIsSymlink filepath =
|
|||||||
hideError UnsatisfiedConstraints $
|
hideError UnsatisfiedConstraints $
|
||||||
handleIO' InappropriateType
|
handleIO' InappropriateType
|
||||||
(handleIfSym filepath)
|
(handleIfSym filepath)
|
||||||
(liftIO $ rmDirectory filepath)
|
(liftIO $ removeEmptyDirectory filepath)
|
||||||
where
|
where
|
||||||
handleIfSym fp e = do
|
handleIfSym fp e = do
|
||||||
isSym <- liftIO $ pathIsSymbolicLink fp
|
isSym <- liftIO $ pathIsSymbolicLink fp
|
||||||
@ -2147,10 +2149,10 @@ getDebugInfo :: ( Alternative m
|
|||||||
DebugInfo
|
DebugInfo
|
||||||
getDebugInfo = do
|
getDebugInfo = do
|
||||||
Dirs {..} <- lift getDirs
|
Dirs {..} <- lift getDirs
|
||||||
let diBaseDir = baseDir
|
let diBaseDir = fromGHCupPath baseDir
|
||||||
let diBinDir = binDir
|
let diBinDir = binDir
|
||||||
diGHCDir <- lift ghcupGHCBaseDir
|
diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir
|
||||||
let diCacheDir = cacheDir
|
let diCacheDir = fromGHCupPath cacheDir
|
||||||
diArch <- lE getArchitecture
|
diArch <- lE getArchitecture
|
||||||
diPlatform <- liftE getPlatform
|
diPlatform <- liftE getPlatform
|
||||||
pure $ DebugInfo { .. }
|
pure $ DebugInfo { .. }
|
||||||
@ -2231,20 +2233,20 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
|
|
||||||
-- unpack
|
-- unpack
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
|
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack
|
||||||
|
|
||||||
workdir <- maybe (pure tmpUnpack)
|
workdir <- maybe (pure tmpUnpack)
|
||||||
(liftE . intoSubdir tmpUnpack)
|
(liftE . intoSubdir tmpUnpack)
|
||||||
(view dlSubdir dlInfo)
|
(view dlSubdir dlInfo)
|
||||||
liftE $ applyAnyPatch patches workdir
|
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
|
||||||
|
|
||||||
pure (workdir, tmpUnpack, tver)
|
pure (workdir, tmpUnpack, tver)
|
||||||
|
|
||||||
-- clone from git
|
-- clone from git
|
||||||
Right GitBranch{..} -> do
|
Right GitBranch{..} -> do
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
|
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
||||||
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
|
tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
|
||||||
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
|
||||||
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||||
@ -2265,16 +2267,16 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
|
|
||||||
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
lEM $ git [ "checkout", "FETCH_HEAD" ]
|
||||||
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
|
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
|
||||||
liftE $ applyAnyPatch patches tmpUnpack
|
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
|
||||||
lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
|
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
|
||||||
lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
|
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
|
||||||
CapturedProcess {..} <- lift $ makeOut
|
CapturedProcess {..} <- lift $ makeOut
|
||||||
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
|
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
|
||||||
case _exitCode of
|
case _exitCode of
|
||||||
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
|
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
|
||||||
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
|
||||||
|
|
||||||
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
|
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
|
||||||
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
|
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
|
||||||
|
|
||||||
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
|
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
|
||||||
@ -2303,9 +2305,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
tmpUnpack
|
tmpUnpack
|
||||||
(do
|
(do
|
||||||
b <- if hadrian
|
b <- if hadrian
|
||||||
then compileHadrianBindist tver workdir ghcdir
|
then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir
|
||||||
else compileMakeBindist tver workdir ghcdir
|
else compileMakeBindist tver (fromGHCupPath workdir) ghcdir
|
||||||
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
|
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
|
||||||
pure (b, bmk)
|
pure (b, bmk)
|
||||||
)
|
)
|
||||||
|
|
||||||
@ -2500,7 +2502,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
|||||||
<> T.unpack cDigest
|
<> T.unpack cDigest
|
||||||
<> ".tar"
|
<> ".tar"
|
||||||
<> takeExtension tar)
|
<> takeExtension tar)
|
||||||
let tarPath = cacheDir </> tarName
|
let tarPath = fromGHCupPath cacheDir </> tarName
|
||||||
copyFileE (workdir </> tar) tarPath False
|
copyFileE (workdir </> tar) tarPath False
|
||||||
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
|
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
|
||||||
pure tarPath
|
pure tarPath
|
||||||
@ -2674,7 +2676,7 @@ upgradeGHCup mtarget force' fatal = do
|
|||||||
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
|
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
|
||||||
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
|
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
|
||||||
dli <- liftE $ getDownloadInfo GHCup latestVer
|
dli <- liftE $ getDownloadInfo GHCup latestVer
|
||||||
tmp <- lift withGHCupTmpDir
|
tmp <- fromGHCupPath <$> lift withGHCupTmpDir
|
||||||
let fn = "ghcup" <> exeExt
|
let fn = "ghcup" <> exeExt
|
||||||
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
|
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
|
||||||
let destDir = takeDirectory destFile
|
let destDir = takeDirectory destFile
|
||||||
@ -2768,7 +2770,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
|
|||||||
GHC -> do
|
GHC -> do
|
||||||
whenM (lift $ fmap not $ ghcInstalled ver)
|
whenM (lift $ fmap not $ ghcInstalled ver)
|
||||||
$ throwE (NotInstalled GHC ver)
|
$ throwE (NotInstalled GHC ver)
|
||||||
bdir <- lift $ ghcupGHCDir ver
|
bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver)
|
||||||
pure (bdir </> "bin" </> ghcBinaryName ver)
|
pure (bdir </> "bin" </> ghcBinaryName ver)
|
||||||
Cabal -> do
|
Cabal -> do
|
||||||
whenM (lift $ fmap not $ cabalInstalled _tvVersion)
|
whenM (lift $ fmap not $ cabalInstalled _tvVersion)
|
||||||
@ -2780,7 +2782,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
|
|||||||
ifM (lift $ isLegacyHLS _tvVersion)
|
ifM (lift $ isLegacyHLS _tvVersion)
|
||||||
(pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
|
(pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
|
||||||
$ do
|
$ do
|
||||||
bdir <- lift $ ghcupHLSDir _tvVersion
|
bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion)
|
||||||
pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
|
pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
|
||||||
|
|
||||||
Stack -> do
|
Stack -> do
|
||||||
@ -2866,6 +2868,7 @@ rmProfilingLibs = do
|
|||||||
forM_ regexes $ \regex ->
|
forM_ regexes $ \regex ->
|
||||||
forM_ ghcs $ \ghc -> do
|
forM_ ghcs $ \ghc -> do
|
||||||
d <- ghcupGHCDir ghc
|
d <- ghcupGHCDir ghc
|
||||||
|
-- TODO: audit findFilesDeep
|
||||||
matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
|
matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
|
||||||
d
|
d
|
||||||
(makeRegexOpts compExtended
|
(makeRegexOpts compExtended
|
||||||
@ -2873,7 +2876,7 @@ rmProfilingLibs = do
|
|||||||
regex
|
regex
|
||||||
)
|
)
|
||||||
forM_ matches $ \m -> do
|
forM_ matches $ \m -> do
|
||||||
let p = d </> m
|
let p = fromGHCupPath d </> m
|
||||||
logDebug $ "rm " <> T.pack p
|
logDebug $ "rm " <> T.pack p
|
||||||
rmFile p
|
rmFile p
|
||||||
|
|
||||||
@ -2892,8 +2895,8 @@ rmShareDir = do
|
|||||||
ghcs <- fmap rights getInstalledGHCs
|
ghcs <- fmap rights getInstalledGHCs
|
||||||
forM_ ghcs $ \ghc -> do
|
forM_ ghcs $ \ghc -> do
|
||||||
d <- ghcupGHCDir ghc
|
d <- ghcupGHCDir ghc
|
||||||
let p = d </> "share"
|
let p = d `appendGHCupPath` "share"
|
||||||
logDebug $ "rm -rf " <> T.pack p
|
logDebug $ "rm -rf " <> T.pack (fromGHCupPath p)
|
||||||
rmPathForcibly p
|
rmPathForcibly p
|
||||||
|
|
||||||
|
|
||||||
@ -2938,9 +2941,9 @@ rmCache :: ( MonadReader env m
|
|||||||
=> m ()
|
=> m ()
|
||||||
rmCache = do
|
rmCache = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
contents <- liftIO $ listDirectory cacheDir
|
contents <- liftIO $ listDirectory (fromGHCupPath cacheDir)
|
||||||
forM_ contents $ \f -> do
|
forM_ contents $ \f -> do
|
||||||
let p = cacheDir </> f
|
let p = fromGHCupPath cacheDir </> f
|
||||||
logDebug $ "rm " <> T.pack p
|
logDebug $ "rm " <> T.pack p
|
||||||
rmFile p
|
rmFile p
|
||||||
|
|
||||||
@ -2953,17 +2956,10 @@ rmTmp :: ( MonadReader env m
|
|||||||
)
|
)
|
||||||
=> m ()
|
=> m ()
|
||||||
rmTmp = do
|
rmTmp = do
|
||||||
tmpdir <- liftIO getCanonicalTemporaryDirectory
|
ghcup_dirs <- liftIO getGHCupTmpDirs
|
||||||
ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles
|
|
||||||
tmpdir
|
|
||||||
(makeRegexOpts compExtended
|
|
||||||
execBlank
|
|
||||||
([s|^ghcup-.*$|] :: ByteString)
|
|
||||||
)
|
|
||||||
forM_ ghcup_dirs $ \f -> do
|
forM_ ghcup_dirs $ \f -> do
|
||||||
let p = tmpdir </> f
|
logDebug $ "rm -rf " <> T.pack (fromGHCupPath f)
|
||||||
logDebug $ "rm -rf " <> T.pack p
|
rmPathForcibly f
|
||||||
rmPathForcibly p
|
|
||||||
|
|
||||||
|
|
||||||
applyAnyPatch :: ( MonadReader env m
|
applyAnyPatch :: ( MonadReader env m
|
||||||
@ -2982,7 +2978,7 @@ applyAnyPatch :: ( MonadReader env m
|
|||||||
applyAnyPatch Nothing _ = pure ()
|
applyAnyPatch Nothing _ = pure ()
|
||||||
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
|
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
|
||||||
applyAnyPatch (Just (Right uris)) workdir = do
|
applyAnyPatch (Just (Right uris)) workdir = do
|
||||||
tmpUnpack <- lift withGHCupTmpDir
|
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
|
||||||
forM_ uris $ \uri -> do
|
forM_ uris $ \uri -> do
|
||||||
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
|
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
|
||||||
liftE $ applyPatch patch workdir
|
liftE $ applyPatch patch workdir
|
||||||
|
|||||||
@ -69,7 +69,6 @@ import Prelude hiding ( abs
|
|||||||
, writeFile
|
, writeFile
|
||||||
)
|
)
|
||||||
import Safe
|
import Safe
|
||||||
import System.Directory
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
@ -145,7 +144,7 @@ getDownloadsF = do
|
|||||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||||
yamlFromCache uri = do
|
yamlFromCache uri = do
|
||||||
Dirs{..} <- getDirs
|
Dirs{..} <- getDirs
|
||||||
pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
|
pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
|
||||||
|
|
||||||
|
|
||||||
etagsFile :: FilePath -> FilePath
|
etagsFile :: FilePath -> FilePath
|
||||||
@ -242,7 +241,7 @@ getBase uri = do
|
|||||||
Settings { metaCache } <- lift getSettings
|
Settings { metaCache } <- lift getSettings
|
||||||
|
|
||||||
-- for local files, let's short-circuit and ignore access time
|
-- for local files, let's short-circuit and ignore access time
|
||||||
if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
|
if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True
|
||||||
| e -> do
|
| e -> do
|
||||||
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
|
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
|
||||||
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
|
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
|
||||||
@ -581,7 +580,7 @@ downloadCached dli mfn = do
|
|||||||
True -> downloadCached' dli mfn Nothing
|
True -> downloadCached' dli mfn Nothing
|
||||||
False -> do
|
False -> do
|
||||||
tmp <- lift withGHCupTmpDir
|
tmp <- lift withGHCupTmpDir
|
||||||
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
|
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False
|
||||||
|
|
||||||
|
|
||||||
downloadCached' :: ( MonadReader env m
|
downloadCached' :: ( MonadReader env m
|
||||||
@ -599,7 +598,7 @@ downloadCached' :: ( MonadReader env m
|
|||||||
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
|
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
|
||||||
downloadCached' dli mfn mDestDir = do
|
downloadCached' dli mfn mDestDir = do
|
||||||
Dirs { cacheDir } <- lift getDirs
|
Dirs { cacheDir } <- lift getDirs
|
||||||
let destDir = fromMaybe cacheDir mDestDir
|
let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir
|
||||||
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
|
let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
|
||||||
let cachfile = destDir </> fn
|
let cachfile = destDir </> fn
|
||||||
fileExists <- liftIO $ doesFileExist cachfile
|
fileExists <- liftIO $ doesFileExist cachfile
|
||||||
|
|||||||
@ -23,6 +23,7 @@ import GHCup.Errors
|
|||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Types.Optics
|
import GHCup.Types.Optics
|
||||||
import GHCup.Types.JSON ( )
|
import GHCup.Types.JSON ( )
|
||||||
|
import GHCup.Utils.Dirs
|
||||||
import GHCup.Utils.File
|
import GHCup.Utils.File
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
@ -46,7 +47,6 @@ import Prelude hiding ( abs
|
|||||||
, writeFile
|
, writeFile
|
||||||
)
|
)
|
||||||
import System.Info
|
import System.Info
|
||||||
import System.Directory
|
|
||||||
import System.OsRelease
|
import System.OsRelease
|
||||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
|
|||||||
@ -26,6 +26,9 @@ module GHCup.Types
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath )
|
||||||
|
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
|
||||||
|
|
||||||
import Control.DeepSeq ( NFData, rnf )
|
import Control.DeepSeq ( NFData, rnf )
|
||||||
import Data.Map.Strict ( Map )
|
import Data.Map.Strict ( Map )
|
||||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||||
@ -438,13 +441,13 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
|
|||||||
instance NFData Settings
|
instance NFData Settings
|
||||||
|
|
||||||
data Dirs = Dirs
|
data Dirs = Dirs
|
||||||
{ baseDir :: FilePath
|
{ baseDir :: GHCupPath
|
||||||
, binDir :: FilePath
|
, binDir :: FilePath
|
||||||
, cacheDir :: FilePath
|
, cacheDir :: GHCupPath
|
||||||
, logsDir :: FilePath
|
, logsDir :: GHCupPath
|
||||||
, confDir :: FilePath
|
, confDir :: GHCupPath
|
||||||
, dbDir :: FilePath
|
, dbDir :: GHCupPath
|
||||||
, recycleDir :: FilePath -- mainly used on windows
|
, recycleDir :: GHCupPath -- mainly used on windows
|
||||||
}
|
}
|
||||||
deriving (Show, GHC.Generic)
|
deriving (Show, GHC.Generic)
|
||||||
|
|
||||||
@ -636,9 +639,11 @@ data InstallDir = IsolateDir FilePath
|
|||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data InstallDirResolved = IsolateDirResolved FilePath
|
data InstallDirResolved = IsolateDirResolved FilePath
|
||||||
| GHCupDir FilePath
|
| GHCupDir GHCupPath
|
||||||
|
| GHCupBinDir FilePath
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
fromInstallDir :: InstallDirResolved -> FilePath
|
fromInstallDir :: InstallDirResolved -> FilePath
|
||||||
fromInstallDir (IsolateDirResolved fp) = fp
|
fromInstallDir (IsolateDirResolved fp) = fp
|
||||||
fromInstallDir (GHCupDir fp) = fp
|
fromInstallDir (GHCupDir fp) = fromGHCupPath fp
|
||||||
|
fromInstallDir (GHCupBinDir fp) = fp
|
||||||
|
|||||||
@ -72,7 +72,6 @@ import GHC.IO.Exception
|
|||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Optics
|
import Optics
|
||||||
import Safe
|
import Safe
|
||||||
import System.Directory hiding ( findFiles, copyFile )
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
@ -281,14 +280,14 @@ rmPlainHLS = do
|
|||||||
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||||
ghcInstalled ver = do
|
ghcInstalled ver = do
|
||||||
ghcdir <- ghcupGHCDir ver
|
ghcdir <- ghcupGHCDir ver
|
||||||
liftIO $ doesDirectoryExist ghcdir
|
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC version is installed from source.
|
-- | Whether the given GHC version is installed from source.
|
||||||
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
|
||||||
ghcSrcInstalled ver = do
|
ghcSrcInstalled ver = do
|
||||||
ghcdir <- ghcupGHCDir ver
|
ghcdir <- ghcupGHCDir ver
|
||||||
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
|
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
|
||||||
|
|
||||||
|
|
||||||
-- | Whether the given GHC version is set as the current.
|
-- | Whether the given GHC version is set as the current.
|
||||||
@ -331,7 +330,7 @@ ghcSet mtarget = do
|
|||||||
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
|
||||||
getInstalledGHCs = do
|
getInstalledGHCs = do
|
||||||
ghcdir <- ghcupGHCBaseDir
|
ghcdir <- ghcupGHCBaseDir
|
||||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
|
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir)
|
||||||
forM fs $ \f -> case parseGHCupGHCDir f of
|
forM fs $ \f -> case parseGHCupGHCDir f of
|
||||||
Right r -> pure $ Right r
|
Right r -> pure $ Right r
|
||||||
Left _ -> pure $ Left f
|
Left _ -> pure $ Left f
|
||||||
@ -434,7 +433,7 @@ getInstalledHLSs = do
|
|||||||
Nothing -> pure $ Left f
|
Nothing -> pure $ Left f
|
||||||
|
|
||||||
hlsdir <- ghcupHLSBaseDir
|
hlsdir <- ghcupHLSBaseDir
|
||||||
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
|
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir)
|
||||||
new <- forM fs $ \f -> case parseGHCupHLSDir f of
|
new <- forM fs $ \f -> case parseGHCupHLSDir f of
|
||||||
Right r -> pure $ Right r
|
Right r -> pure $ Right r
|
||||||
Left _ -> pure $ Left f
|
Left _ -> pure $ Left f
|
||||||
@ -519,7 +518,7 @@ hlsInstalled ver = do
|
|||||||
isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
|
||||||
isLegacyHLS ver = do
|
isLegacyHLS ver = do
|
||||||
bdir <- ghcupHLSDir ver
|
bdir <- ghcupHLSDir ver
|
||||||
not <$> liftIO (doesDirectoryExist bdir)
|
not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir)
|
||||||
|
|
||||||
|
|
||||||
-- Return the currently set hls version, if any.
|
-- Return the currently set hls version, if any.
|
||||||
@ -620,7 +619,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr
|
|||||||
-> m [FilePath]
|
-> m [FilePath]
|
||||||
hlsInternalServerScripts ver mghcVer = do
|
hlsInternalServerScripts ver mghcVer = do
|
||||||
dir <- ghcupHLSDir ver
|
dir <- ghcupHLSDir ver
|
||||||
let bdir = dir </> "bin"
|
let bdir = fromGHCupPath dir </> "bin"
|
||||||
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
|
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
|
||||||
<$> liftIO (listDirectory bdir)
|
<$> liftIO (listDirectory bdir)
|
||||||
|
|
||||||
@ -631,7 +630,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh
|
|||||||
-> Maybe Version -- ^ optional GHC version
|
-> Maybe Version -- ^ optional GHC version
|
||||||
-> m [FilePath]
|
-> m [FilePath]
|
||||||
hlsInternalServerBinaries ver mghcVer = do
|
hlsInternalServerBinaries ver mghcVer = do
|
||||||
dir <- ghcupHLSDir ver
|
dir <- fromGHCupPath <$> ghcupHLSDir ver
|
||||||
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
|
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
|
||||||
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
|
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
|
||||||
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
|
fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
|
||||||
@ -645,7 +644,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow
|
|||||||
-> Version -- ^ GHC version
|
-> Version -- ^ GHC version
|
||||||
-> m [FilePath]
|
-> m [FilePath]
|
||||||
hlsInternalServerLibs ver ghcVer = do
|
hlsInternalServerLibs ver ghcVer = do
|
||||||
dir <- ghcupHLSDir ver
|
dir <- fromGHCupPath <$> ghcupHLSDir ver
|
||||||
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
|
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
|
||||||
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
|
(Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
|
||||||
fmap (bdir </>) <$> liftIO (listDirectory bdir)
|
fmap (bdir </>) <$> liftIO (listDirectory bdir)
|
||||||
@ -849,21 +848,21 @@ getArchiveFiles av = do
|
|||||||
|
|
||||||
|
|
||||||
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
|
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
|
||||||
=> FilePath -- ^ unpacked tar dir
|
=> GHCupPath -- ^ unpacked tar dir
|
||||||
-> TarDir -- ^ how to descend
|
-> TarDir -- ^ how to descend
|
||||||
-> Excepts '[TarDirDoesNotExist] m FilePath
|
-> Excepts '[TarDirDoesNotExist] m GHCupPath
|
||||||
intoSubdir bdir tardir = case tardir of
|
intoSubdir bdir tardir = case tardir of
|
||||||
RealDir pr -> do
|
RealDir pr -> do
|
||||||
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
|
whenM (fmap not . liftIO . doesDirectoryExist $ (fromGHCupPath (bdir `appendGHCupPath` pr)))
|
||||||
(throwE $ TarDirDoesNotExist tardir)
|
(throwE $ TarDirDoesNotExist tardir)
|
||||||
pure (bdir </> pr)
|
pure (bdir `appendGHCupPath` pr)
|
||||||
RegexDir r -> do
|
RegexDir r -> do
|
||||||
let rs = split (`elem` pathSeparators) r
|
let rs = split (`elem` pathSeparators) r
|
||||||
foldlM
|
foldlM
|
||||||
(\y x ->
|
(\y x ->
|
||||||
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
|
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
|
||||||
[] -> throwE $ TarDirDoesNotExist tardir
|
[] -> throwE $ TarDirDoesNotExist tardir
|
||||||
(p : _) -> pure (y </> p)) . sort
|
(p : _) -> pure (y `appendGHCupPath` p)) . sort
|
||||||
)
|
)
|
||||||
bdir
|
bdir
|
||||||
rs
|
rs
|
||||||
@ -909,7 +908,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
|
|||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> m FilePath
|
-> m FilePath
|
||||||
ghcInternalBinDir ver = do
|
ghcInternalBinDir ver = do
|
||||||
ghcdir <- ghcupGHCDir ver
|
ghcdir <- fromGHCupPath <$> ghcupGHCDir ver
|
||||||
pure (ghcdir </> "bin")
|
pure (ghcdir </> "bin")
|
||||||
|
|
||||||
|
|
||||||
@ -1045,7 +1044,6 @@ getChangeLog dls tool (Right tag) =
|
|||||||
-- | Execute a build action while potentially cleaning up:
|
-- | Execute a build action while potentially cleaning up:
|
||||||
--
|
--
|
||||||
-- 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
|
|
||||||
runBuildAction :: ( MonadReader env m
|
runBuildAction :: ( MonadReader env m
|
||||||
, HasDirs env
|
, HasDirs env
|
||||||
, HasSettings env
|
, HasSettings env
|
||||||
@ -1056,7 +1054,7 @@ runBuildAction :: ( MonadReader env m
|
|||||||
, MonadFail m
|
, MonadFail m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
runBuildAction bdir action = do
|
runBuildAction bdir action = do
|
||||||
@ -1083,7 +1081,7 @@ cleanUpOnError :: ( MonadReader env m
|
|||||||
, MonadFail m
|
, MonadFail m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
cleanUpOnError bdir action = do
|
cleanUpOnError bdir action = do
|
||||||
@ -1104,7 +1102,7 @@ cleanFinally :: ( MonadReader env m
|
|||||||
, MonadFail m
|
, MonadFail m
|
||||||
, MonadCatch m
|
, MonadCatch m
|
||||||
)
|
)
|
||||||
=> FilePath -- ^ build directory (cleaned up depending on Settings)
|
=> GHCupPath -- ^ build directory (cleaned up depending on Settings)
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
-> Excepts e m a
|
-> Excepts e m a
|
||||||
cleanFinally bdir action = do
|
cleanFinally bdir action = do
|
||||||
@ -1115,10 +1113,10 @@ cleanFinally bdir action = do
|
|||||||
|
|
||||||
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
|
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
|
||||||
-- printing other errors without crashing.
|
-- printing other errors without crashing.
|
||||||
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
|
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
|
||||||
rmBDir dir = withRunInIO (\run -> run $
|
rmBDir dir = withRunInIO (\run -> run $
|
||||||
liftIO $ handleIO (\e -> run $ logWarn $
|
liftIO $ handleIO (\e -> run $ logWarn $
|
||||||
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
|
"Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e))
|
||||||
$ hideError doesNotExistErrorType
|
$ hideError doesNotExistErrorType
|
||||||
$ rmPathForcibly dir)
|
$ rmPathForcibly dir)
|
||||||
|
|
||||||
@ -1204,7 +1202,7 @@ createLink :: ( MonadMask m
|
|||||||
createLink link exe
|
createLink link exe
|
||||||
| isWindows = do
|
| isWindows = do
|
||||||
dirs <- getDirs
|
dirs <- getDirs
|
||||||
let shimGen = cacheDir dirs </> "gs.exe"
|
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
|
||||||
|
|
||||||
let shim = dropExtension exe <.> "shim"
|
let shim = dropExtension exe <.> "shim"
|
||||||
-- For hardlinks, link needs to be absolute.
|
-- For hardlinks, link needs to be absolute.
|
||||||
@ -1248,8 +1246,8 @@ ensureGlobalTools
|
|||||||
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
|
||||||
void $ (\DigestError{} -> do
|
void $ (\DigestError{} -> do
|
||||||
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
|
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
|
||||||
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
|
lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
|
||||||
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
|
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
|
||||||
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
|
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
|
||||||
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
|
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
|
||||||
| otherwise = pure ()
|
| otherwise = pure ()
|
||||||
@ -1258,14 +1256,14 @@ ensureGlobalTools
|
|||||||
-- | Ensure ghcup directory structure exists.
|
-- | Ensure ghcup directory structure exists.
|
||||||
ensureDirectories :: Dirs -> IO ()
|
ensureDirectories :: Dirs -> IO ()
|
||||||
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
|
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
|
||||||
createDirRecursive' baseDir
|
createDirRecursive' (fromGHCupPath baseDir)
|
||||||
createDirRecursive' (baseDir </> "ghc")
|
createDirRecursive' (fromGHCupPath baseDir </> "ghc")
|
||||||
createDirRecursive' binDir
|
createDirRecursive' binDir
|
||||||
createDirRecursive' cacheDir
|
createDirRecursive' (fromGHCupPath cacheDir)
|
||||||
createDirRecursive' logsDir
|
createDirRecursive' (fromGHCupPath logsDir)
|
||||||
createDirRecursive' confDir
|
createDirRecursive' (fromGHCupPath confDir)
|
||||||
createDirRecursive' trashDir
|
createDirRecursive' (fromGHCupPath trashDir)
|
||||||
createDirRecursive' dbDir
|
createDirRecursive' (fromGHCupPath dbDir)
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
|
||||||
@ -1293,7 +1291,7 @@ installDestSanityCheck :: ( MonadIO m
|
|||||||
Excepts '[DirNotEmpty] m ()
|
Excepts '[DirNotEmpty] m ()
|
||||||
installDestSanityCheck (IsolateDirResolved isoDir) = do
|
installDestSanityCheck (IsolateDirResolved isoDir) = do
|
||||||
hideErrorDef [doesNotExistErrorType] () $ do
|
hideErrorDef [doesNotExistErrorType] () $ do
|
||||||
contents <- liftIO $ getDirectoryContentsRecursive isoDir
|
contents <- liftIO $ getDirectoryContentsRecursiveUnsafe isoDir
|
||||||
unless (null contents) (throwE $ DirNotEmpty isoDir)
|
unless (null contents) (throwE $ DirNotEmpty isoDir)
|
||||||
installDestSanityCheck _ = pure ()
|
installDestSanityCheck _ = pure ()
|
||||||
|
|
||||||
@ -1342,6 +1340,6 @@ recordedInstallationFile :: ( MonadReader env m
|
|||||||
-> m FilePath
|
-> m FilePath
|
||||||
recordedInstallationFile t v' = do
|
recordedInstallationFile t v' = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
pure (dbDir </> prettyShow t </> T.unpack (tVerToText v'))
|
pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -3,6 +3,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
Module : GHCup.Utils.Dirs
|
Module : GHCup.Utils.Dirs
|
||||||
@ -30,6 +31,74 @@ module GHCup.Utils.Dirs
|
|||||||
, getConfigFilePath
|
, getConfigFilePath
|
||||||
, useXDG
|
, useXDG
|
||||||
, cleanupTrash
|
, cleanupTrash
|
||||||
|
|
||||||
|
, GHCupPath
|
||||||
|
, appendGHCupPath
|
||||||
|
, fromGHCupPath
|
||||||
|
, createTempGHCupDirectory
|
||||||
|
, getGHCupTmpDirs
|
||||||
|
|
||||||
|
, removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
|
||||||
|
-- System.Directory re-exports
|
||||||
|
, createDirectory
|
||||||
|
, createDirectoryIfMissing
|
||||||
|
, renameDirectory
|
||||||
|
, listDirectory
|
||||||
|
, getDirectoryContents
|
||||||
|
, getCurrentDirectory
|
||||||
|
, setCurrentDirectory
|
||||||
|
, withCurrentDirectory
|
||||||
|
, getHomeDirectory
|
||||||
|
, XdgDirectory(..)
|
||||||
|
, getXdgDirectory
|
||||||
|
, XdgDirectoryList(..)
|
||||||
|
, getXdgDirectoryList
|
||||||
|
, getAppUserDataDirectory
|
||||||
|
, getUserDocumentsDirectory
|
||||||
|
, getTemporaryDirectory
|
||||||
|
, removeFile
|
||||||
|
, renameFile
|
||||||
|
, renamePath
|
||||||
|
, getFileSize
|
||||||
|
, canonicalizePath
|
||||||
|
, makeAbsolute
|
||||||
|
, makeRelativeToCurrentDirectory
|
||||||
|
, doesPathExist
|
||||||
|
, doesFileExist
|
||||||
|
, doesDirectoryExist
|
||||||
|
, findExecutable
|
||||||
|
, findExecutables
|
||||||
|
, findExecutablesInDirectories
|
||||||
|
, findFile
|
||||||
|
, findFileWith
|
||||||
|
, findFilesWith
|
||||||
|
, exeExtension
|
||||||
|
, createFileLink
|
||||||
|
, createDirectoryLink
|
||||||
|
, removeDirectoryLink
|
||||||
|
, pathIsSymbolicLink
|
||||||
|
, getSymbolicLinkTarget
|
||||||
|
, Permissions
|
||||||
|
, emptyPermissions
|
||||||
|
, readable
|
||||||
|
, writable
|
||||||
|
, executable
|
||||||
|
, searchable
|
||||||
|
, setOwnerReadable
|
||||||
|
, setOwnerWritable
|
||||||
|
, setOwnerExecutable
|
||||||
|
, setOwnerSearchable
|
||||||
|
, getPermissions
|
||||||
|
, setPermissions
|
||||||
|
, copyPermissions
|
||||||
|
, getAccessTime
|
||||||
|
, getModificationTime
|
||||||
|
, setAccessTime
|
||||||
|
, setModificationTime
|
||||||
|
, isSymbolicLink
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -41,23 +110,35 @@ import GHCup.Types.Optics
|
|||||||
import GHCup.Utils.MegaParsec
|
import GHCup.Utils.MegaParsec
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
|
import GHCup.Utils.File.Common
|
||||||
|
import GHCup.Utils.String.QQ
|
||||||
|
|
||||||
|
import Control.DeepSeq (NFData, rnf)
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Resource hiding (throwM)
|
import Control.Monad.Trans.Resource hiding (throwM)
|
||||||
|
import Data.List
|
||||||
|
import Data.ByteString ( ByteString )
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
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
|
||||||
import System.Directory
|
import System.Directory hiding ( removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
, findFiles
|
||||||
|
)
|
||||||
|
import qualified System.Directory as SD
|
||||||
|
|
||||||
import System.DiskSpace
|
import System.DiskSpace
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Temp
|
import System.IO.Temp
|
||||||
|
import Text.Regex.Posix
|
||||||
|
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
@ -67,6 +148,41 @@ import Control.Concurrent (threadDelay)
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---------------------------
|
||||||
|
--[ GHCupPath utilities ]--
|
||||||
|
---------------------------
|
||||||
|
|
||||||
|
-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
|
||||||
|
--
|
||||||
|
-- The constructor is not exported.
|
||||||
|
newtype GHCupPath = GHCupPath FilePath
|
||||||
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
instance NFData GHCupPath where
|
||||||
|
rnf (GHCupPath fp) = rnf fp
|
||||||
|
|
||||||
|
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
|
||||||
|
appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)
|
||||||
|
|
||||||
|
fromGHCupPath :: GHCupPath -> FilePath
|
||||||
|
fromGHCupPath (GHCupPath gp) = gp
|
||||||
|
|
||||||
|
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
|
||||||
|
createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d
|
||||||
|
|
||||||
|
|
||||||
|
getGHCupTmpDirs :: IO [GHCupPath]
|
||||||
|
getGHCupTmpDirs = do
|
||||||
|
tmpdir <- getCanonicalTemporaryDirectory
|
||||||
|
ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
|
||||||
|
tmpdir
|
||||||
|
(makeRegexOpts compExtended
|
||||||
|
execBlank
|
||||||
|
([s|^ghcup-.*$|] :: ByteString)
|
||||||
|
)
|
||||||
|
pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (("ghcup-" `isPrefixOf`) . takeDirectory) $ ghcup_dirs)
|
||||||
|
|
||||||
|
|
||||||
------------------------------
|
------------------------------
|
||||||
--[ GHCup base directories ]--
|
--[ GHCup base directories ]--
|
||||||
------------------------------
|
------------------------------
|
||||||
@ -76,11 +192,11 @@ import Control.Concurrent (threadDelay)
|
|||||||
--
|
--
|
||||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
|
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
|
||||||
ghcupBaseDir :: IO FilePath
|
ghcupBaseDir :: IO GHCupPath
|
||||||
ghcupBaseDir
|
ghcupBaseDir
|
||||||
| isWindows = do
|
| isWindows = do
|
||||||
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
|
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
|
||||||
pure (bdir </> "ghcup")
|
pure (GHCupPath (bdir </> "ghcup"))
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
xdg <- useXDG
|
xdg <- useXDG
|
||||||
if xdg
|
if xdg
|
||||||
@ -90,19 +206,19 @@ ghcupBaseDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".local" </> "share")
|
pure (home </> ".local" </> "share")
|
||||||
pure (bdir </> "ghcup")
|
pure (GHCupPath (bdir </> "ghcup"))
|
||||||
else do
|
else do
|
||||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||||
Just r -> pure r
|
Just r -> pure r
|
||||||
Nothing -> liftIO getHomeDirectory
|
Nothing -> liftIO getHomeDirectory
|
||||||
pure (bdir </> ".ghcup")
|
pure (GHCupPath (bdir </> ".ghcup"))
|
||||||
|
|
||||||
|
|
||||||
-- | ~/.ghcup by default
|
-- | ~/.ghcup by default
|
||||||
--
|
--
|
||||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
|
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
|
||||||
ghcupConfigDir :: IO FilePath
|
ghcupConfigDir :: IO GHCupPath
|
||||||
ghcupConfigDir
|
ghcupConfigDir
|
||||||
| isWindows = ghcupBaseDir
|
| isWindows = ghcupBaseDir
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
@ -114,12 +230,12 @@ ghcupConfigDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".config")
|
pure (home </> ".config")
|
||||||
pure (bdir </> "ghcup")
|
pure (GHCupPath (bdir </> "ghcup"))
|
||||||
else do
|
else do
|
||||||
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
||||||
Just r -> pure r
|
Just r -> pure r
|
||||||
Nothing -> liftIO getHomeDirectory
|
Nothing -> liftIO getHomeDirectory
|
||||||
pure (bdir </> ".ghcup")
|
pure (GHCupPath (bdir </> ".ghcup"))
|
||||||
|
|
||||||
|
|
||||||
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
@ -127,7 +243,7 @@ ghcupConfigDir
|
|||||||
-- (which, sadly is not strictly xdg spec).
|
-- (which, sadly is not strictly xdg spec).
|
||||||
ghcupBinDir :: IO FilePath
|
ghcupBinDir :: IO FilePath
|
||||||
ghcupBinDir
|
ghcupBinDir
|
||||||
| isWindows = ghcupBaseDir <&> (</> "bin")
|
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
xdg <- useXDG
|
xdg <- useXDG
|
||||||
if xdg
|
if xdg
|
||||||
@ -137,16 +253,16 @@ ghcupBinDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".local" </> "bin")
|
pure (home </> ".local" </> "bin")
|
||||||
else ghcupBaseDir <&> (</> "bin")
|
else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
|
||||||
|
|
||||||
|
|
||||||
-- | Defaults to '~/.ghcup/cache'.
|
-- | Defaults to '~/.ghcup/cache'.
|
||||||
--
|
--
|
||||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
|
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
|
||||||
ghcupCacheDir :: IO FilePath
|
ghcupCacheDir :: IO GHCupPath
|
||||||
ghcupCacheDir
|
ghcupCacheDir
|
||||||
| isWindows = ghcupBaseDir <&> (</> "cache")
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
xdg <- useXDG
|
xdg <- useXDG
|
||||||
if xdg
|
if xdg
|
||||||
@ -156,17 +272,17 @@ ghcupCacheDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".cache")
|
pure (home </> ".cache")
|
||||||
pure (bdir </> "ghcup")
|
pure (GHCupPath (bdir </> "ghcup"))
|
||||||
else ghcupBaseDir <&> (</> "cache")
|
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
|
||||||
|
|
||||||
|
|
||||||
-- | Defaults to '~/.ghcup/logs'.
|
-- | Defaults to '~/.ghcup/logs'.
|
||||||
--
|
--
|
||||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
|
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
|
||||||
ghcupLogsDir :: IO FilePath
|
ghcupLogsDir :: IO GHCupPath
|
||||||
ghcupLogsDir
|
ghcupLogsDir
|
||||||
| isWindows = ghcupBaseDir <&> (</> "logs")
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
xdg <- useXDG
|
xdg <- useXDG
|
||||||
if xdg
|
if xdg
|
||||||
@ -176,17 +292,17 @@ ghcupLogsDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".cache")
|
pure (home </> ".cache")
|
||||||
pure (bdir </> "ghcup" </> "logs")
|
pure (GHCupPath (bdir </> "ghcup" </> "logs"))
|
||||||
else ghcupBaseDir <&> (</> "logs")
|
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
|
||||||
|
|
||||||
|
|
||||||
-- | Defaults to '~/.ghcup/db.
|
-- | Defaults to '~/.ghcup/db.
|
||||||
--
|
--
|
||||||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
||||||
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
|
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
|
||||||
ghcupDbDir :: IO FilePath
|
ghcupDbDir :: IO GHCupPath
|
||||||
ghcupDbDir
|
ghcupDbDir
|
||||||
| isWindows = ghcupBaseDir <&> (</> "db")
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
xdg <- useXDG
|
xdg <- useXDG
|
||||||
if xdg
|
if xdg
|
||||||
@ -196,14 +312,14 @@ ghcupDbDir
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
home <- liftIO getHomeDirectory
|
home <- liftIO getHomeDirectory
|
||||||
pure (home </> ".cache")
|
pure (home </> ".cache")
|
||||||
pure (bdir </> "ghcup" </> "db")
|
pure (GHCupPath (bdir </> "ghcup" </> "db"))
|
||||||
else ghcupBaseDir <&> (</> "db")
|
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
|
||||||
|
|
||||||
|
|
||||||
-- | '~/.ghcup/trash'.
|
-- | '~/.ghcup/trash'.
|
||||||
-- Mainly used on windows to improve file removal operations
|
-- Mainly used on windows to improve file removal operations
|
||||||
ghcupRecycleDir :: IO FilePath
|
ghcupRecycleDir :: IO GHCupPath
|
||||||
ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
|
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -227,7 +343,7 @@ getAllDirs = do
|
|||||||
getConfigFilePath :: (MonadIO m) => m FilePath
|
getConfigFilePath :: (MonadIO m) => m FilePath
|
||||||
getConfigFilePath = do
|
getConfigFilePath = do
|
||||||
confDir <- liftIO ghcupConfigDir
|
confDir <- liftIO ghcupConfigDir
|
||||||
pure $ confDir </> "config.yaml"
|
pure $ fromGHCupPath confDir </> "config.yaml"
|
||||||
|
|
||||||
ghcupConfigFile :: (MonadIO m)
|
ghcupConfigFile :: (MonadIO m)
|
||||||
=> Excepts '[JSONError] m UserSettings
|
=> Excepts '[JSONError] m UserSettings
|
||||||
@ -245,10 +361,10 @@ ghcupConfigFile = do
|
|||||||
|
|
||||||
|
|
||||||
-- | ~/.ghcup/ghc by default.
|
-- | ~/.ghcup/ghc by default.
|
||||||
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
|
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
||||||
ghcupGHCBaseDir = do
|
ghcupGHCBaseDir = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
pure (baseDir </> "ghc")
|
pure (baseDir `appendGHCupPath` "ghc")
|
||||||
|
|
||||||
|
|
||||||
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
||||||
@ -257,11 +373,11 @@ ghcupGHCBaseDir = do
|
|||||||
-- * 8.8.4
|
-- * 8.8.4
|
||||||
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
||||||
=> GHCTargetVersion
|
=> GHCTargetVersion
|
||||||
-> m FilePath
|
-> m GHCupPath
|
||||||
ghcupGHCDir ver = do
|
ghcupGHCDir ver = do
|
||||||
ghcbasedir <- ghcupGHCBaseDir
|
ghcbasedir <- ghcupGHCBaseDir
|
||||||
let verdir = T.unpack $ tVerToText ver
|
let verdir = T.unpack $ tVerToText ver
|
||||||
pure (ghcbasedir </> verdir)
|
pure (ghcbasedir `appendGHCupPath` verdir)
|
||||||
|
|
||||||
|
|
||||||
-- | See 'ghcupToolParser'.
|
-- | See 'ghcupToolParser'.
|
||||||
@ -274,19 +390,19 @@ parseGHCupHLSDir (T.pack -> fp) =
|
|||||||
throwEither $ MP.parse version' "" fp
|
throwEither $ MP.parse version' "" fp
|
||||||
|
|
||||||
-- | ~/.ghcup/hls by default, for new-style installs.
|
-- | ~/.ghcup/hls by default, for new-style installs.
|
||||||
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
|
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
||||||
ghcupHLSBaseDir = do
|
ghcupHLSBaseDir = do
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
pure (baseDir </> "hls")
|
pure (baseDir `appendGHCupPath` "hls")
|
||||||
|
|
||||||
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
|
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
|
||||||
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
||||||
=> Version
|
=> Version
|
||||||
-> m FilePath
|
-> m GHCupPath
|
||||||
ghcupHLSDir ver = do
|
ghcupHLSDir ver = do
|
||||||
basedir <- ghcupHLSBaseDir
|
basedir <- ghcupHLSBaseDir
|
||||||
let verdir = T.unpack $ prettyVer ver
|
let verdir = T.unpack $ prettyVer ver
|
||||||
pure (basedir </> verdir)
|
pure (basedir `appendGHCupPath` verdir)
|
||||||
|
|
||||||
mkGhcupTmpDir :: ( MonadReader env m
|
mkGhcupTmpDir :: ( MonadReader env m
|
||||||
, HasDirs env
|
, HasDirs env
|
||||||
@ -296,8 +412,8 @@ mkGhcupTmpDir :: ( MonadReader env m
|
|||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
, MonadIO m)
|
, MonadIO m)
|
||||||
=> m FilePath
|
=> m GHCupPath
|
||||||
mkGhcupTmpDir = do
|
mkGhcupTmpDir = GHCupPath <$> do
|
||||||
tmpdir <- liftIO getCanonicalTemporaryDirectory
|
tmpdir <- liftIO getCanonicalTemporaryDirectory
|
||||||
|
|
||||||
let minSpace = 5000 -- a rough guess, aight?
|
let minSpace = 5000 -- a rough guess, aight?
|
||||||
@ -333,14 +449,14 @@ withGHCupTmpDir :: ( MonadReader env m
|
|||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
, MonadIO m)
|
, MonadIO m)
|
||||||
=> m FilePath
|
=> m GHCupPath
|
||||||
withGHCupTmpDir = snd <$> withRunInIO (\run ->
|
withGHCupTmpDir = snd <$> withRunInIO (\run ->
|
||||||
run
|
run
|
||||||
$ allocate
|
$ allocate
|
||||||
(run mkGhcupTmpDir)
|
(run mkGhcupTmpDir)
|
||||||
(\fp ->
|
(\fp ->
|
||||||
handleIO (\e -> run
|
handleIO (\e -> run
|
||||||
$ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
|
$ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
|
||||||
. rmPathForcibly
|
. rmPathForcibly
|
||||||
$ fp))
|
$ fp))
|
||||||
|
|
||||||
@ -381,12 +497,27 @@ cleanupTrash :: ( MonadIO m
|
|||||||
=> m ()
|
=> m ()
|
||||||
cleanupTrash = do
|
cleanupTrash = do
|
||||||
Dirs { recycleDir } <- getDirs
|
Dirs { recycleDir } <- getDirs
|
||||||
contents <- liftIO $ listDirectory recycleDir
|
contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
|
||||||
if null contents
|
if null contents
|
||||||
then pure ()
|
then pure ()
|
||||||
else do
|
else do
|
||||||
logWarn ("Removing leftover files in " <> T.pack recycleDir)
|
logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir))
|
||||||
forM_ contents (\fp -> handleIO (\e ->
|
forM_ contents (\fp -> handleIO (\e ->
|
||||||
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
|
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
|
||||||
) $ liftIO $ removePathForcibly (recycleDir </> fp))
|
) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- System.Directory re-exports with GHCupPath
|
||||||
|
|
||||||
|
removeDirectory :: GHCupPath -> IO ()
|
||||||
|
removeDirectory (GHCupPath fp) = SD.removeDirectory fp
|
||||||
|
|
||||||
|
removeDirectoryRecursive :: GHCupPath -> IO ()
|
||||||
|
removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp
|
||||||
|
|
||||||
|
removePathForcibly :: GHCupPath -> IO ()
|
||||||
|
removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
37
lib/GHCup/Utils/Dirs.hs-boot
Normal file
37
lib/GHCup/Utils/Dirs.hs-boot
Normal file
@ -0,0 +1,37 @@
|
|||||||
|
module GHCup.Utils.Dirs
|
||||||
|
( GHCupPath
|
||||||
|
, appendGHCupPath
|
||||||
|
, fromGHCupPath
|
||||||
|
, createTempGHCupDirectory
|
||||||
|
, removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Control.DeepSeq (NFData)
|
||||||
|
|
||||||
|
|
||||||
|
-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
|
||||||
|
newtype GHCupPath = GHCupPath FilePath
|
||||||
|
|
||||||
|
instance Show GHCupPath where
|
||||||
|
|
||||||
|
instance Eq GHCupPath where
|
||||||
|
|
||||||
|
instance Ord GHCupPath where
|
||||||
|
|
||||||
|
instance NFData GHCupPath where
|
||||||
|
|
||||||
|
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
|
||||||
|
|
||||||
|
fromGHCupPath :: GHCupPath -> FilePath
|
||||||
|
|
||||||
|
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
|
||||||
|
|
||||||
|
removeDirectory :: GHCupPath -> IO ()
|
||||||
|
|
||||||
|
removeDirectoryRecursive :: GHCupPath -> IO ()
|
||||||
|
|
||||||
|
removePathForcibly :: GHCupPath -> IO ()
|
||||||
|
|
||||||
@ -19,6 +19,7 @@ module GHCup.Utils.File (
|
|||||||
#endif
|
#endif
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import GHCup.Utils.Dirs
|
||||||
import GHCup.Utils.File.Common
|
import GHCup.Utils.File.Common
|
||||||
#if IS_WINDOWS
|
#if IS_WINDOWS
|
||||||
import GHCup.Utils.File.Windows
|
import GHCup.Utils.File.Windows
|
||||||
@ -32,7 +33,6 @@ import GHC.IO ( evaluate )
|
|||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import System.Directory hiding (findFiles, copyFile)
|
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Data.List (nub)
|
import Data.List (nub)
|
||||||
@ -42,7 +42,7 @@ import Control.DeepSeq (force)
|
|||||||
|
|
||||||
-- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively.
|
-- | Like 'mergeFileTree', except reads the entire source base dir to determine files to copy recursively.
|
||||||
mergeFileTreeAll :: MonadIO m
|
mergeFileTreeAll :: MonadIO m
|
||||||
=> FilePath -- ^ source base directory from which to install findFiles
|
=> GHCupPath -- ^ source base directory from which to install findFiles
|
||||||
-> FilePath -- ^ destination base dir
|
-> FilePath -- ^ destination base dir
|
||||||
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
||||||
-> m [FilePath]
|
-> m [FilePath]
|
||||||
@ -54,12 +54,12 @@ mergeFileTreeAll sourceBase destBase copyOp = do
|
|||||||
|
|
||||||
|
|
||||||
mergeFileTree :: MonadIO m
|
mergeFileTree :: MonadIO m
|
||||||
=> FilePath -- ^ source base directory from which to install findFiles
|
=> GHCupPath -- ^ source base directory from which to install findFiles
|
||||||
-> [FilePath] -- ^ relative filepaths from source base directory
|
-> [FilePath] -- ^ relative filepaths from source base directory
|
||||||
-> FilePath -- ^ destination base dir
|
-> FilePath -- ^ destination base dir
|
||||||
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
|
||||||
-> m ()
|
-> m ()
|
||||||
mergeFileTree sourceBase sources destBase copyOp = do
|
mergeFileTree (fromGHCupPath -> sourceBase) sources destBase copyOp = do
|
||||||
-- These checks are not atomic, but we perform them to have
|
-- These checks are not atomic, but we perform them to have
|
||||||
-- the opportunity to abort before copying has started.
|
-- the opportunity to abort before copying has started.
|
||||||
--
|
--
|
||||||
|
|||||||
@ -9,6 +9,7 @@ module GHCup.Utils.File.Common (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
|
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
|
||||||
import GHCup.Types(ProcessError(..), CapturedProcess(..))
|
import GHCup.Types(ProcessError(..), CapturedProcess(..))
|
||||||
|
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
@ -16,7 +17,11 @@ import Data.Maybe
|
|||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Void
|
import Data.Void
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import System.Directory hiding (findFiles, copyFile)
|
import System.Directory hiding ( removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
, findFiles
|
||||||
|
)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Text.Regex.Posix
|
import Text.Regex.Posix
|
||||||
|
|
||||||
@ -94,7 +99,7 @@ findFiles path regex = do
|
|||||||
contents <- listDirectory path
|
contents <- listDirectory path
|
||||||
pure $ filter (match regex) contents
|
pure $ filter (match regex) contents
|
||||||
|
|
||||||
findFilesDeep :: FilePath -> Regex -> IO [FilePath]
|
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
|
||||||
findFilesDeep path regex = do
|
findFilesDeep path regex = do
|
||||||
contents <- getDirectoryContentsRecursive path
|
contents <- getDirectoryContentsRecursive path
|
||||||
pure $ filter (match regex) contents
|
pure $ filter (match regex) contents
|
||||||
|
|||||||
@ -17,6 +17,7 @@ Some of these functions use sophisticated logging.
|
|||||||
-}
|
-}
|
||||||
module GHCup.Utils.File.Posix where
|
module GHCup.Utils.File.Posix where
|
||||||
|
|
||||||
|
import GHCup.Utils.Dirs
|
||||||
import GHCup.Utils.File.Common
|
import GHCup.Utils.File.Common
|
||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
@ -42,7 +43,6 @@ import GHC.IO.Exception
|
|||||||
import System.IO ( stderr, hClose, hSetBinaryMode )
|
import System.IO ( stderr, hClose, hSetBinaryMode )
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Directory hiding ( copyFile )
|
|
||||||
import System.Posix.Directory
|
import System.Posix.Directory
|
||||||
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
|
||||||
import System.Posix.Internals ( withFilePath )
|
import System.Posix.Internals ( withFilePath )
|
||||||
@ -56,6 +56,7 @@ import qualified Control.Exception as EX
|
|||||||
import qualified Data.Sequence as Sq
|
import qualified Data.Sequence as Sq
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as E
|
import qualified Data.Text.Encoding as E
|
||||||
|
import qualified System.Posix.Directory as PD
|
||||||
import qualified System.Posix.Files as PF
|
import qualified System.Posix.Files as PF
|
||||||
import qualified System.Posix.Process as SPP
|
import qualified System.Posix.Process as SPP
|
||||||
import qualified System.Posix.IO as SPI
|
import qualified System.Posix.IO as SPI
|
||||||
@ -101,7 +102,7 @@ execLogged exe args chdir lfile env = do
|
|||||||
Settings {..} <- getSettings
|
Settings {..} <- getSettings
|
||||||
Dirs {..} <- getDirs
|
Dirs {..} <- getDirs
|
||||||
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args
|
||||||
let logfile = logsDir </> lfile <> ".log"
|
let logfile = fromGHCupPath logsDir </> lfile <> ".log"
|
||||||
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
|
||||||
closeFd
|
closeFd
|
||||||
(action verbose noColor)
|
(action verbose noColor)
|
||||||
@ -550,3 +551,6 @@ install from to fail' = do
|
|||||||
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
| PF.isSymbolicLink fs = recreateSymlink from to fail'
|
||||||
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
| otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)
|
||||||
|
|
||||||
|
|
||||||
|
removeEmptyDirectory :: FilePath -> IO ()
|
||||||
|
removeEmptyDirectory = PD.removeDirectory
|
||||||
|
|||||||
@ -17,7 +17,7 @@ Some of these functions use sophisticated logging.
|
|||||||
module GHCup.Utils.File.Windows where
|
module GHCup.Utils.File.Windows where
|
||||||
|
|
||||||
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
|
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
|
||||||
import GHCup.Utils.Dirs
|
import GHCup.Utils.Dirs hiding ( copyFile )
|
||||||
import GHCup.Utils.File.Common
|
import GHCup.Utils.File.Common
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
@ -32,7 +32,6 @@ import Data.List
|
|||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import GHC.IO.Handle
|
import GHC.IO.Handle
|
||||||
import System.Directory hiding ( copyFile )
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO
|
import System.IO
|
||||||
@ -284,3 +283,6 @@ deleteFile = WS.deleteFile
|
|||||||
|
|
||||||
install :: FilePath -> FilePath -> Bool -> IO ()
|
install :: FilePath -> FilePath -> Bool -> IO ()
|
||||||
install = copyFile
|
install = copyFile
|
||||||
|
|
||||||
|
removeEmptyDirectory :: FilePath -> IO ()
|
||||||
|
removeEmptyDirectory = WS.removeDirectory
|
||||||
|
|||||||
@ -17,6 +17,7 @@ module GHCup.Utils.Logger where
|
|||||||
|
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Types.Optics
|
import GHCup.Types.Optics
|
||||||
|
import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
|
||||||
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
|
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
|
|
||||||
@ -117,14 +118,14 @@ initGHCupFileLogging :: ( MonadReader env m
|
|||||||
) => m FilePath
|
) => m FilePath
|
||||||
initGHCupFileLogging = do
|
initGHCupFileLogging = do
|
||||||
Dirs { logsDir } <- getDirs
|
Dirs { logsDir } <- getDirs
|
||||||
let logfile = logsDir </> "ghcup.log"
|
let logfile = fromGHCupPath logsDir </> "ghcup.log"
|
||||||
logFiles <- liftIO $ findFiles
|
logFiles <- liftIO $ findFiles
|
||||||
logsDir
|
(fromGHCupPath 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 . recycleFile . (fromGHCupPath logsDir </>)
|
||||||
|
|
||||||
liftIO $ writeFile logfile ""
|
liftIO $ writeFile logfile ""
|
||||||
pure logfile
|
pure logfile
|
||||||
|
|||||||
@ -27,6 +27,7 @@ module GHCup.Utils.Prelude
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
import GHCup.Types.Optics
|
import GHCup.Types.Optics
|
||||||
@ -44,9 +45,8 @@ import Control.Monad.IO.Class
|
|||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
|
import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Foldable
|
|
||||||
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
import Data.List.NonEmpty ( NonEmpty( (:|) ))
|
||||||
import Data.String
|
import Data.String
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
@ -56,9 +56,12 @@ import Haskus.Utils.Types.List
|
|||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.IO.Temp
|
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
import System.Directory hiding ( copyFile )
|
import System.Directory hiding ( removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
, copyFile
|
||||||
|
)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Control.Retry
|
import Control.Retry
|
||||||
@ -397,30 +400,6 @@ createDirRecursive' p =
|
|||||||
_ -> throwIO e
|
_ -> throwIO e
|
||||||
|
|
||||||
|
|
||||||
-- | Recursively copy the contents of one directory to another path.
|
|
||||||
--
|
|
||||||
-- This is a rip-off of Cabal library.
|
|
||||||
copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
|
|
||||||
copyDirectoryRecursive srcDir destDir doCopy = do
|
|
||||||
srcFiles <- getDirectoryContentsRecursive srcDir
|
|
||||||
copyFilesWith destDir [ (srcDir, f)
|
|
||||||
| f <- srcFiles ]
|
|
||||||
where
|
|
||||||
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
|
|
||||||
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
|
|
||||||
copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
|
|
||||||
copyFilesWith targetDir srcFiles = do
|
|
||||||
|
|
||||||
-- Create parent directories for everything
|
|
||||||
let dirs = map (targetDir </>) . nub . map takeDirectory $ fmap snd srcFiles
|
|
||||||
traverse_ (createDirectoryIfMissing True) dirs
|
|
||||||
|
|
||||||
-- Copy all the files
|
|
||||||
sequence_ [ let src = srcBase </> srcFile
|
|
||||||
dest = targetDir </> srcFile
|
|
||||||
in doCopy src dest
|
|
||||||
| (srcBase, srcFile) <- srcFiles ]
|
|
||||||
|
|
||||||
|
|
||||||
-- | List all the files in a directory and all subdirectories.
|
-- | List all the files in a directory and all subdirectories.
|
||||||
--
|
--
|
||||||
@ -429,8 +408,12 @@ copyDirectoryRecursive srcDir destDir doCopy = do
|
|||||||
-- the source directory structure changes before the list is used.
|
-- the source directory structure changes before the list is used.
|
||||||
--
|
--
|
||||||
-- TODO: use streamly
|
-- TODO: use streamly
|
||||||
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
|
getDirectoryContentsRecursive :: GHCupPath -> IO [FilePath]
|
||||||
getDirectoryContentsRecursive topdir = recurseDirectories [""]
|
getDirectoryContentsRecursive (fromGHCupPath -> topdir) = getDirectoryContentsRecursiveUnsafe topdir
|
||||||
|
|
||||||
|
|
||||||
|
getDirectoryContentsRecursiveUnsafe :: FilePath -> IO [FilePath]
|
||||||
|
getDirectoryContentsRecursiveUnsafe topdir = recurseDirectories [""]
|
||||||
where
|
where
|
||||||
recurseDirectories :: [FilePath] -> IO [FilePath]
|
recurseDirectories :: [FilePath] -> IO [FilePath]
|
||||||
recurseDirectories [] = return []
|
recurseDirectories [] = return []
|
||||||
@ -464,14 +447,14 @@ recyclePathForcibly :: ( MonadIO m
|
|||||||
, HasDirs env
|
, HasDirs env
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
)
|
)
|
||||||
=> FilePath
|
=> GHCupPath
|
||||||
-> m ()
|
-> m ()
|
||||||
recyclePathForcibly fp
|
recyclePathForcibly fp
|
||||||
| isWindows = do
|
| isWindows = do
|
||||||
Dirs { recycleDir } <- getDirs
|
Dirs { recycleDir } <- getDirs
|
||||||
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
|
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
|
||||||
let dest = tmp </> takeFileName fp
|
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
|
||||||
liftIO (moveFile fp dest)
|
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
|
||||||
`catch`
|
`catch`
|
||||||
(\e -> if | isDoesNotExistError e -> pure ()
|
(\e -> if | isDoesNotExistError e -> pure ()
|
||||||
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
|
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
|
||||||
@ -484,7 +467,7 @@ recyclePathForcibly fp
|
|||||||
rmPathForcibly :: ( MonadIO m
|
rmPathForcibly :: ( MonadIO m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
)
|
)
|
||||||
=> FilePath
|
=> GHCupPath
|
||||||
-> m ()
|
-> m ()
|
||||||
rmPathForcibly fp
|
rmPathForcibly fp
|
||||||
| isWindows = recover (liftIO $ removePathForcibly fp)
|
| isWindows = recover (liftIO $ removePathForcibly fp)
|
||||||
@ -492,7 +475,7 @@ rmPathForcibly fp
|
|||||||
|
|
||||||
|
|
||||||
rmDirectory :: (MonadIO m, MonadMask m)
|
rmDirectory :: (MonadIO m, MonadMask m)
|
||||||
=> FilePath
|
=> GHCupPath
|
||||||
-> m ()
|
-> m ()
|
||||||
rmDirectory fp
|
rmDirectory fp
|
||||||
| isWindows = recover (liftIO $ removeDirectory fp)
|
| isWindows = recover (liftIO $ removeDirectory fp)
|
||||||
@ -512,11 +495,11 @@ recycleFile fp
|
|||||||
| isWindows = do
|
| isWindows = do
|
||||||
Dirs { recycleDir } <- getDirs
|
Dirs { recycleDir } <- getDirs
|
||||||
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
|
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
|
||||||
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
|
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
|
||||||
let dest = tmp </> takeFileName fp
|
let dest = fromGHCupPath tmp </> takeFileName fp
|
||||||
liftIO (moveFile fp dest)
|
liftIO (moveFile fp dest)
|
||||||
`catch`
|
`catch`
|
||||||
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
|
(\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
|
||||||
`finally`
|
`finally`
|
||||||
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
|
||||||
| otherwise = liftIO $ removeFile fp
|
| otherwise = liftIO $ removeFile fp
|
||||||
|
|||||||
@ -1,6 +1,10 @@
|
|||||||
module GHCup.Utils.Prelude.Posix where
|
module GHCup.Utils.Prelude.Posix where
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory hiding ( removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
|
, removePathForcibly
|
||||||
|
, findFiles
|
||||||
|
)
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user