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

Use strongly types `GHCupPath` and restrict destructive operations

This commit is contained in:
Julian Ospald 2022-05-13 21:35:34 +02:00
parent fa924eac15
commit c9790e5823
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
21 changed files with 421 additions and 257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/ghcup/BrickMain.hs
View File

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

1
app/ghcup/GHCup/OptParse/Common.hs
View File

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

4
app/ghcup/GHCup/OptParse/Compile.hs
View File

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

13
app/ghcup/GHCup/OptParse/Install.hs
View File

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

1
app/ghcup/GHCup/OptParse/Run.hs
View File

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

9
app/ghcup/GHCup/OptParse/Whereis.hs
View File

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

2
app/ghcup/Main.hs
View File

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

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

9
lib/GHCup/Download.hs
View File

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

2
lib/GHCup/Platform.hs
View File

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

21
lib/GHCup/Types.hs
View File

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

66
lib/GHCup/Utils.hs
View File

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

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

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

12
lib/GHCup/Utils/File.hs
View File

@ -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,9 +42,9 @@ 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]
mergeFileTreeAll sourceBase destBase copyOp = do mergeFileTreeAll sourceBase destBase copyOp = do
(force -> !sourceFiles) <- liftIO (force -> !sourceFiles) <- liftIO
@ -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
lib/GHCup/Utils/File/Common.hs
View File

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

8
lib/GHCup/Utils/File/Posix.hs
View File

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

6
lib/GHCup/Utils/File/Windows.hs
View File

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

7
lib/GHCup/Utils/Logger.hs
View File

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

61
lib/GHCup/Utils/Prelude.hs
View File

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

6
lib/GHCup/Utils/Prelude/Posix.hs
View File

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