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

Use strongly types GHCupPath and restrict destructive operations

Browse Source
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 Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Directory ( canonicalizePath )
import System.FilePath
import System.Exit
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 Prelude hiding ( appendFile )
import Safe
import System.Directory
import System.Process ( readProcess )
import System.FilePath
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
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> 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" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9
@ -553,7 +553,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case keepDirs settings of
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> 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" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9

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

@ -18,6 +18,7 @@ import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
@ -446,21 +447,21 @@ install installCommand settings getAppState' runLogger = case installCommand of
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> 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.")
pure $ ExitFailure 3
VLeft err@(V (BuildFailed tmpdir _, ())) -> do
case keepDirs settings of
Never -> runLogger (logError $ T.pack $ prettyShow err)
_ -> 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.")
pure $ ExitFailure 3
VLeft e -> do
runLogger $ do
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
@ -512,7 +513,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
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
installHLS :: InstallOptions -> IO ExitCode
@ -572,7 +573,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
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
installStack :: InstallOptions -> IO ExitCode
@ -623,6 +624,6 @@ install installCommand settings getAppState' runLogger = case installCommand of
VLeft e -> do
runLogger $ do
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

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

@ -32,7 +32,6 @@ import Data.List ( intercalate )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Directory
import System.FilePath
import System.Environment
import System.Exit

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

@ -17,6 +17,7 @@ import GHCup
import GHCup.Errors
import GHCup.OptParse.Common
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
@ -299,7 +300,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure $ ExitFailure 30
(WhereisBaseDir, _) -> do
liftIO $ putStr baseDir
liftIO $ putStr $ fromGHCupPath baseDir
pure ExitSuccess
(WhereisBinDir, _) -> do
@ -307,13 +308,13 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
pure ExitSuccess
(WhereisCacheDir, _) -> do
liftIO $ putStr cacheDir
liftIO $ putStr $ fromGHCupPath cacheDir
pure ExitSuccess
(WhereisLogsDir, _) -> do
liftIO $ putStr logsDir
liftIO $ putStr $ fromGHCupPath logsDir
pure ExitSuccess
(WhereisConfDir, _) -> do
liftIO $ putStr confDir
liftIO $ putStr $ fromGHCupPath confDir
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
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
Nuke -> pure ()

192
lib/GHCup.hs
View File

@ -77,11 +77,9 @@ import Prelude hiding ( abs
, writeFile
)
import Safe hiding ( at )
import System.Directory hiding ( findFiles, copyFile )
import System.Environment
import System.FilePath
import System.IO.Error
import System.IO.Temp
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import URI.ByteString
@ -293,8 +291,8 @@ installPackedGHC dl msubdir inst ver forceInstall = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack)
@ -319,7 +317,7 @@ installUnpackedGHC :: ( MonadReader env m
, MonadResource 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
-> Version -- ^ The GHC version
-> Bool -- ^ Force install
@ -351,13 +349,13 @@ installUnpackedGHC path inst ver forceInstall
("./configure" : ("--prefix=" <> fromInstallDir inst)
: alpineArgs
)
(Just path)
(Just $ fromGHCupPath path)
"ghc-configure"
Nothing
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> tmpInstallDest, "install"] (Just path)
lift $ logInfo $ "Merging file tree from \"" <> T.pack tmpInstallDest <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)
lift $ logInfo $ "Merging file tree from \"" <> T.pack (fromGHCupPath tmpInstallDest) <> "\" to \"" <> T.pack (fromInstallDir inst) <> "\""
fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
(fromInstallDir inst)
(\f t -> liftIO (install f t (not forceInstall)))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
@ -472,11 +470,11 @@ installCabalBindist dlinfo ver installDir forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- 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
IsolateDir isoDir -> do -- isolated install
@ -484,7 +482,7 @@ installCabalBindist dlinfo ver installDir forceInstall = do
liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall
liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall
-- | Install an unpacked cabal distribution.Symbol
@ -501,7 +499,7 @@ installCabalUnpacked path inst ver forceInstall = do
let destFileName = cabalFile
<> (case inst of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
let destPath = fromInstallDir inst </> destFileName
@ -614,11 +612,11 @@ installHLSBindist dlinfo ver installDir forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- 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
if
@ -636,7 +634,7 @@ installHLSBindist dlinfo ver installDir forceInstall = do
GHCupInternal -> do
if legacy
then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall
then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack
@ -671,8 +669,8 @@ installHLSUnpacked path inst ver forceInstall = do
PlatformRequest { .. } <- lift getPlatformReq
lift $ logInfo "Installing HLS"
tmpInstallDest <- lift withGHCupTmpDir
lEM $ make ["DESTDIR=" <> tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
fs <- mergeFileTreeAll (tmpInstallDest </> dropDrive (fromInstallDir inst))
lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)
fs <- mergeFileTreeAll (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))
(fromInstallDir inst)
(\f t -> liftIO (install f t (not forceInstall)))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromInstallDir inst)
@ -702,7 +700,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
let toF = dropSuffix exeExt f
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver
_ -> ("~" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
@ -720,7 +718,7 @@ installHLSUnpackedLegacy path installDir ver forceInstall = do
toF = wrapper
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
srcWrapperPath = path </> wrapper <> exeExt
@ -827,8 +825,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
@ -839,7 +837,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
-- clone from git
Right GitBranch{..} -> do
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
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)"
@ -859,7 +857,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
lEM $ git fetch_args
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)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
@ -868,7 +866,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
. packageDescription
$ 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
pure (tmpUnpack, tver)
@ -879,30 +877,30 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
liftE $ runBuildAction
workdir
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do
let tmpInstallDir = workdir </> "out"
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
let tmpInstallDir = fromGHCupPath workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir
-- apply patches
liftE $ applyAnyPatch patches workdir
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
-- set up project files
cp <- case cabalProject of
Just (Left cp)
| isAbsolute cp -> do
copyFileE cp (workdir </> "cabal.project") False
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project"
| otherwise -> pure (takeFileName cp)
Just (Right uri) -> do
tmpUnpack <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False
copyFileE cp (workdir </> "cabal.project") False
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project"
Nothing -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do
tmpUnpack <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False
copyFileE cpl (workdir </> cp <.> "local") False
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
liftIO $ createDirRecursive' tmpInstallDir
@ -923,7 +921,9 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
"exe:haskell-language-server"
, "exe:haskell-language-server-wrapper"]
)
(Just workdir) "cabal" Nothing
(Just $ fromGHCupPath workdir)
"cabal"
Nothing
pure ghcInstallDir
forM_ artifacts $ \artifact -> do
@ -931,14 +931,14 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)
liftIO $ rmPathForcibly artifact
liftIO $ hideError NoSuchThing $ rmFile artifact
case installDir of
IsolateDir isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True
GHCupInternal -> do
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True
liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True
)
pure installVer
@ -1044,8 +1044,8 @@ installStackBindist dlinfo ver installDir forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-- the subdir of the archive where we do the work
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
liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall
GHCupInternal -> do -- regular install
liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall
liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall
-- | Install an unpacked stack distribution.
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
-> Version
-> Bool -- ^ Force install
@ -1072,13 +1072,13 @@ installStackUnpacked path installDir ver forceInstall = do
let destFileName = stackFile
<> (case installDir of
IsolateDirResolved _ -> ""
GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver
_ -> ("-" <>) . T.unpack . prettyVer $ ver
)
<> exeExt
destPath = fromInstallDir installDir </> destFileName
copyFileE
(path </> stackFile <> exeExt)
(fromGHCupPath path </> stackFile <> exeExt)
destPath
(not forceInstall)
lift $ chmod_755 destPath
@ -1160,7 +1160,7 @@ setGHC ver sghc mBinDir = do
when (isNothing mBinDir) $ do
-- 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
@ -1180,7 +1180,7 @@ setGHC ver sghc mBinDir = do
-> m ()
symlinkShareDir ghcdir ver' = do
Dirs {..} <- getDirs
let destdir = baseDir
let destdir = fromGHCupPath baseDir
case sghc of
SetGHCOnly -> do
let sharedir = "share"
@ -1799,19 +1799,20 @@ rmGHCVer ver = do
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
-- 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
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack dir
forM_ files (liftIO . deleteFile . (\f -> dir </> dropDrive f))
f <- recordedInstallationFile GHC ver
liftIO $ deleteFile f
liftIO $ hideError doesNotExistErrorType $ deleteFile f
removeEmptyDirsRecursive dir
survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
lift $ recyclePathForcibly dir
lift $ recyclePathForcibly dir'
v' <-
handle
@ -1823,7 +1824,7 @@ rmGHCVer ver = do
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
@ -1882,7 +1883,8 @@ rmHLSVer ver = do
-- delete all set symlinks
liftE rmPlainHLS
hlsDir <- ghcupHLSDir ver
hlsDir' <- ghcupHLSDir ver
let hlsDir = fromGHCupPath hlsDir'
lift (getInstalledFiles HLS (mkTVer ver)) >>= \case
Just files -> do
lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir
@ -1894,7 +1896,7 @@ rmHLSVer ver = do
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
recyclePathForcibly hlsDir
recyclePathForcibly hlsDir'
when (Just ver == isHlsSet) $ do
-- set latest hls
@ -1974,7 +1976,7 @@ rmGhcup = do
tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
moveFile ghcupFilepath (tempFilepath </> "ghcup")
moveFile ghcupFilepath (fromGHCupPath tempFilepath </> "ghcup")
else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
@ -2024,7 +2026,7 @@ rmGhcupDirs = do
, recycleDir
} <- getDirs
let envFilePath = baseDir </> "env"
let envFilePath = fromGHCupPath baseDir </> "env"
confFilePath <- getConfigFilePath
@ -2038,14 +2040,14 @@ rmGhcupDirs = do
handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir
when isWindows $ do
logInfo $ "removing " <> T.pack (baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir </> "msys64")
logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")
handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")
handleRm $ removeEmptyDirsRecursive baseDir
handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir)
-- report files in baseDir that are left-over after
-- the standard location deletions above
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles (fromGHCupPath baseDir)
where
handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
@ -2062,15 +2064,15 @@ rmGhcupDirs = do
logInfo "removing Ghcup Config File"
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 =
-- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do
logInfo $ "removing " <> T.pack dir
logInfo $ "removing " <> T.pack (fromGHCupPath 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 binDir
@ -2085,7 +2087,7 @@ rmGhcupDirs = do
reportRemainingFiles dir = do
-- force the files so the errors don't leak
(force -> !remainingFiles) <- liftIO
(getDirectoryContentsRecursive dir >>= evaluate)
(getDirectoryContentsRecursiveUnsafe dir >>= evaluate)
let normalizedFilePaths = fmap normalise remainingFiles
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
@ -2113,7 +2115,7 @@ removeDirIfEmptyOrIsSymlink filepath =
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
(liftIO $ rmDirectory filepath)
(liftIO $ removeEmptyDirectory filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
@ -2147,10 +2149,10 @@ getDebugInfo :: ( Alternative m
DebugInfo
getDebugInfo = do
Dirs {..} <- lift getDirs
let diBaseDir = baseDir
let diBaseDir = fromGHCupPath baseDir
let diBinDir = binDir
diGHCDir <- lift ghcupGHCBaseDir
let diCacheDir = cacheDir
diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir
let diCacheDir = fromGHCupPath cacheDir
diArch <- lE getArchitecture
diPlatform <- liftE getPlatform
pure $ DebugInfo { .. }
@ -2231,20 +2233,20 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack
workdir <- maybe (pure tmpUnpack)
(liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo)
liftE $ applyAnyPatch patches workdir
liftE $ applyAnyPatch patches (fromGHCupPath workdir)
pure (workdir, tmpUnpack, tver)
-- clone from git
Right GitBranch{..} -> do
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
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)"
@ -2265,16 +2267,16 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
lEM $ git [ "checkout", "FETCH_HEAD" ]
lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
liftE $ applyAnyPatch patches tmpUnpack
lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of
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))
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
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
@ -2303,9 +2305,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
tmpUnpack
(do
b <- if hadrian
then compileHadrianBindist tver workdir ghcdir
else compileMakeBindist tver workdir ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir
else compileMakeBindist tver (fromGHCupPath workdir) ghcdir
bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)
pure (b, bmk)
)
@ -2500,7 +2502,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
<> T.unpack cDigest
<> ".tar"
<> takeExtension tar)
let tarPath = cacheDir </> tarName
let tarPath = fromGHCupPath cacheDir </> tarName
copyFileE (workdir </> tar) tarPath False
lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath
@ -2674,7 +2676,7 @@ upgradeGHCup mtarget force' fatal = do
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer
tmp <- lift withGHCupTmpDir
tmp <- fromGHCupPath <$> lift withGHCupTmpDir
let fn = "ghcup" <> exeExt
p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile
@ -2768,7 +2770,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
GHC -> do
whenM (lift $ fmap not $ ghcInstalled ver)
$ throwE (NotInstalled GHC ver)
bdir <- lift $ ghcupGHCDir ver
bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver)
pure (bdir </> "bin" </> ghcBinaryName ver)
Cabal -> do
whenM (lift $ fmap not $ cabalInstalled _tvVersion)
@ -2780,7 +2782,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
ifM (lift $ isLegacyHLS _tvVersion)
(pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
$ do
bdir <- lift $ ghcupHLSDir _tvVersion
bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion)
pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
Stack -> do
@ -2866,6 +2868,7 @@ rmProfilingLibs = do
forM_ regexes $ \regex ->
forM_ ghcs $ \ghc -> do
d <- ghcupGHCDir ghc
-- TODO: audit findFilesDeep
matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep
d
(makeRegexOpts compExtended
@ -2873,7 +2876,7 @@ rmProfilingLibs = do
regex
)
forM_ matches $ \m -> do
let p = d </> m
let p = fromGHCupPath d </> m
logDebug $ "rm " <> T.pack p
rmFile p
@ -2892,8 +2895,8 @@ rmShareDir = do
ghcs <- fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> do
d <- ghcupGHCDir ghc
let p = d </> "share"
logDebug $ "rm -rf " <> T.pack p
let p = d `appendGHCupPath` "share"
logDebug $ "rm -rf " <> T.pack (fromGHCupPath p)
rmPathForcibly p
@ -2938,9 +2941,9 @@ rmCache :: ( MonadReader env m
=> m ()
rmCache = do
Dirs {..} <- getDirs
contents <- liftIO $ listDirectory cacheDir
contents <- liftIO $ listDirectory (fromGHCupPath cacheDir)
forM_ contents $ \f -> do
let p = cacheDir </> f
let p = fromGHCupPath cacheDir </> f
logDebug $ "rm " <> T.pack p
rmFile p
@ -2953,17 +2956,10 @@ rmTmp :: ( MonadReader env m
)
=> m ()
rmTmp = do
tmpdir <- liftIO getCanonicalTemporaryDirectory
ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles
tmpdir
(makeRegexOpts compExtended
execBlank
([s|^ghcup-.*$|] :: ByteString)
)
ghcup_dirs <- liftIO getGHCupTmpDirs
forM_ ghcup_dirs $ \f -> do
let p = tmpdir </> f
logDebug $ "rm -rf " <> T.pack p
rmPathForcibly p
logDebug $ "rm -rf " <> T.pack (fromGHCupPath f)
rmPathForcibly f
applyAnyPatch :: ( MonadReader env m
@ -2982,7 +2978,7 @@ applyAnyPatch :: ( MonadReader env m
applyAnyPatch Nothing _ = pure ()
applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir
applyAnyPatch (Just (Right uris)) workdir = do
tmpUnpack <- lift withGHCupTmpDir
tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir
forM_ uris $ \uri -> do
patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False
liftE $ applyPatch patch workdir

9
lib/GHCup/Download.hs
View File

@ -69,7 +69,6 @@ import Prelude hiding ( abs
, writeFile
)
import Safe
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
@ -145,7 +144,7 @@ getDownloadsF = do
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
yamlFromCache uri = do
Dirs{..} <- getDirs
pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
etagsFile :: FilePath -> FilePath
@ -242,7 +241,7 @@ getBase uri = do
Settings { metaCache } <- lift getSettings
-- 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
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@ -581,7 +580,7 @@ downloadCached dli mfn = do
True -> downloadCached' dli mfn Nothing
False -> do
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
@ -599,7 +598,7 @@ downloadCached' :: ( MonadReader env m
-> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
downloadCached' dli mfn mDestDir = do
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 cachfile = destDir </> fn
fileExists <- liftIO $ doesFileExist cachfile

2
lib/GHCup/Platform.hs
View File

@ -23,6 +23,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
@ -46,7 +47,6 @@ import Prelude hiding ( abs
, writeFile
)
import System.Info
import System.Directory
import System.OsRelease
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix

21
lib/GHCup/Types.hs
View File

@ -26,6 +26,9 @@ module GHCup.Types
)
where
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath )
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
import Control.DeepSeq ( NFData, rnf )
import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) )
@ -438,13 +441,13 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
instance NFData Settings
data Dirs = Dirs
{ baseDir :: FilePath
{ baseDir :: GHCupPath
, binDir :: FilePath
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
, dbDir :: FilePath
, recycleDir :: FilePath -- mainly used on windows
, cacheDir :: GHCupPath
, logsDir :: GHCupPath
, confDir :: GHCupPath
, dbDir :: GHCupPath
, recycleDir :: GHCupPath -- mainly used on windows
}
deriving (Show, GHC.Generic)
@ -636,9 +639,11 @@ data InstallDir = IsolateDir FilePath
deriving (Eq, Show)
data InstallDirResolved = IsolateDirResolved FilePath
| GHCupDir FilePath
| GHCupDir GHCupPath
| GHCupBinDir FilePath
deriving (Eq, Show)
fromInstallDir :: InstallDirResolved -> FilePath
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 Optics
import Safe
import System.Directory hiding ( findFiles, copyFile )
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
@ -281,14 +280,14 @@ rmPlainHLS = do
ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesDirectoryExist ghcdir
liftIO $ doesDirectoryExist (fromGHCupPath ghcdir)
-- | Whether the given GHC version is installed from source.
ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile)
-- | 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 = do
ghcdir <- ghcupGHCBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir)
forM fs $ \f -> case parseGHCupGHCDir f of
Right r -> pure $ Right r
Left _ -> pure $ Left f
@ -434,7 +433,7 @@ getInstalledHLSs = do
Nothing -> pure $ Left f
hlsdir <- ghcupHLSBaseDir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir)
new <- forM fs $ \f -> case parseGHCupHLSDir f of
Right r -> pure $ Right r
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 ver = do
bdir <- ghcupHLSDir ver
not <$> liftIO (doesDirectoryExist bdir)
not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir)
-- Return the currently set hls version, if any.
@ -620,7 +619,7 @@ hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThr
-> m [FilePath]
hlsInternalServerScripts ver mghcVer = do
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)
<$> liftIO (listDirectory bdir)
@ -631,7 +630,7 @@ hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadTh
-> Maybe Version -- ^ optional GHC version
-> m [FilePath]
hlsInternalServerBinaries ver mghcVer = do
dir <- ghcupHLSDir ver
dir <- fromGHCupPath <$> ghcupHLSDir ver
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
(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)
@ -645,7 +644,7 @@ hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow
-> Version -- ^ GHC version
-> m [FilePath]
hlsInternalServerLibs ver ghcVer = do
dir <- ghcupHLSDir ver
dir <- fromGHCupPath <$> ghcupHLSDir ver
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))]
fmap (bdir </>) <$> liftIO (listDirectory bdir)
@ -849,21 +848,21 @@ getArchiveFiles av = do
intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> FilePath -- ^ unpacked tar dir
=> GHCupPath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m FilePath
-> Excepts '[TarDirDoesNotExist] m GHCupPath
intoSubdir bdir tardir = case tardir of
RealDir pr -> do
whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
whenM (fmap not . liftIO . doesDirectoryExist $ (fromGHCupPath (bdir `appendGHCupPath` pr)))
(throwE $ TarDirDoesNotExist tardir)
pure (bdir </> pr)
pure (bdir `appendGHCupPath` pr)
RegexDir r -> do
let rs = split (`elem` pathSeparators) r
foldlM
(\y x ->
(handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
(handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case
[] -> throwE $ TarDirDoesNotExist tardir
(p : _) -> pure (y </> p)) . sort
(p : _) -> pure (y `appendGHCupPath` p)) . sort
)
bdir
rs
@ -909,7 +908,7 @@ ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m,
=> GHCTargetVersion
-> m FilePath
ghcInternalBinDir ver = do
ghcdir <- ghcupGHCDir ver
ghcdir <- fromGHCupPath <$> ghcupGHCDir ver
pure (ghcdir </> "bin")
@ -1045,7 +1044,6 @@ getChangeLog dls tool (Right tag) =
-- | Execute a build action while potentially cleaning up:
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
runBuildAction :: ( MonadReader env m
, HasDirs env
, HasSettings env
@ -1056,7 +1054,7 @@ runBuildAction :: ( MonadReader env m
, MonadFail 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
runBuildAction bdir action = do
@ -1083,7 +1081,7 @@ cleanUpOnError :: ( MonadReader env m
, MonadFail 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
cleanUpOnError bdir action = do
@ -1104,7 +1102,7 @@ cleanFinally :: ( MonadReader env m
, MonadFail 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
cleanFinally bdir action = do
@ -1115,10 +1113,10 @@ cleanFinally bdir action = do
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- 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 $
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
$ rmPathForcibly dir)
@ -1204,7 +1202,7 @@ createLink :: ( MonadMask m
createLink link exe
| isWindows = do
dirs <- getDirs
let shimGen = cacheDir dirs </> "gs.exe"
let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"
let shim = dropExtension exe <.> "shim"
-- For hardlinks, link needs to be absolute.
@ -1248,8 +1246,8 @@ ensureGlobalTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))
lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe")
liftE @'[GPGError, DigestError , DownloadFailed] $ dl
) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
| otherwise = pure ()
@ -1258,14 +1256,14 @@ ensureGlobalTools
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' (fromGHCupPath baseDir)
createDirRecursive' (fromGHCupPath baseDir </> "ghc")
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
createDirRecursive' trashDir
createDirRecursive' dbDir
createDirRecursive' (fromGHCupPath cacheDir)
createDirRecursive' (fromGHCupPath logsDir)
createDirRecursive' (fromGHCupPath confDir)
createDirRecursive' (fromGHCupPath trashDir)
createDirRecursive' (fromGHCupPath dbDir)
pure ()
@ -1293,7 +1291,7 @@ installDestSanityCheck :: ( MonadIO m
Excepts '[DirNotEmpty] m ()
installDestSanityCheck (IsolateDirResolved isoDir) = do
hideErrorDef [doesNotExistErrorType] () $ do
contents <- liftIO $ getDirectoryContentsRecursive isoDir
contents <- liftIO $ getDirectoryContentsRecursiveUnsafe isoDir
unless (null contents) (throwE $ DirNotEmpty isoDir)
installDestSanityCheck _ = pure ()
@ -1342,6 +1340,6 @@ recordedInstallationFile :: ( MonadReader env m
-> m FilePath
recordedInstallationFile t v' = do
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 FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : GHCup.Utils.Dirs
@ -30,6 +31,74 @@ module GHCup.Utils.Dirs
, getConfigFilePath
, useXDG
, 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
@ -41,23 +110,35 @@ import GHCup.Types.Optics
import GHCup.Utils.MegaParsec
import GHCup.Utils.Logger
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.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.List
import Data.ByteString ( ByteString )
import Data.Bifunctor
import Data.Maybe
import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
import System.Directory
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import qualified System.Directory as SD
import System.DiskSpace
import System.Environment
import System.FilePath
import System.IO.Temp
import Text.Regex.Posix
import qualified Data.ByteString as BS
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 ]--
------------------------------
@ -76,11 +192,11 @@ import Control.Concurrent (threadDelay)
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO FilePath
ghcupBaseDir :: IO GHCupPath
ghcupBaseDir
| isWindows = do
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
| otherwise = do
xdg <- useXDG
if xdg
@ -90,19 +206,19 @@ ghcupBaseDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
pure (GHCupPath (bdir </> ".ghcup"))
-- | ~/.ghcup by default
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
ghcupConfigDir :: IO FilePath
ghcupConfigDir :: IO GHCupPath
ghcupConfigDir
| isWindows = ghcupBaseDir
| otherwise = do
@ -114,12 +230,12 @@ ghcupConfigDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".config")
pure (bdir </> "ghcup")
pure (GHCupPath (bdir </> "ghcup"))
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (bdir </> ".ghcup")
pure (GHCupPath (bdir </> ".ghcup"))
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@ -127,7 +243,7 @@ ghcupConfigDir
-- (which, sadly is not strictly xdg spec).
ghcupBinDir :: IO FilePath
ghcupBinDir
| isWindows = ghcupBaseDir <&> (</> "bin")
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
| otherwise = do
xdg <- useXDG
if xdg
@ -137,16 +253,16 @@ ghcupBinDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
-- | Defaults to '~/.ghcup/cache'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
ghcupCacheDir :: IO FilePath
ghcupCacheDir :: IO GHCupPath
ghcupCacheDir
| isWindows = ghcupBaseDir <&> (</> "cache")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
| otherwise = do
xdg <- useXDG
if xdg
@ -156,17 +272,17 @@ ghcupCacheDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
pure (GHCupPath (bdir </> "ghcup"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
-- | Defaults to '~/.ghcup/logs'.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
ghcupLogsDir :: IO FilePath
ghcupLogsDir :: IO GHCupPath
ghcupLogsDir
| isWindows = ghcupBaseDir <&> (</> "logs")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
| otherwise = do
xdg <- useXDG
if xdg
@ -176,17 +292,17 @@ ghcupLogsDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
pure (GHCupPath (bdir </> "ghcup" </> "logs"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
-- | Defaults to '~/.ghcup/db.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO FilePath
ghcupDbDir :: IO GHCupPath
ghcupDbDir
| isWindows = ghcupBaseDir <&> (</> "db")
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
| otherwise = do
xdg <- useXDG
if xdg
@ -196,14 +312,14 @@ ghcupDbDir
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "db")
else ghcupBaseDir <&> (</> "db")
pure (GHCupPath (bdir </> "ghcup" </> "db"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
ghcupRecycleDir :: IO GHCupPath
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
@ -227,7 +343,7 @@ getAllDirs = do
getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath = do
confDir <- liftIO ghcupConfigDir
pure $ confDir </> "config.yaml"
pure $ fromGHCupPath confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
@ -245,10 +361,10 @@ ghcupConfigFile = do
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
ghcupGHCBaseDir = do
Dirs {..} <- getDirs
pure (baseDir </> "ghc")
pure (baseDir `appendGHCupPath` "ghc")
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@ -257,11 +373,11 @@ ghcupGHCBaseDir = do
-- * 8.8.4
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> GHCTargetVersion
-> m FilePath
-> m GHCupPath
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir </> verdir)
pure (ghcbasedir `appendGHCupPath` verdir)
-- | See 'ghcupToolParser'.
@ -274,19 +390,19 @@ parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp
-- | ~/.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
Dirs {..} <- getDirs
pure (baseDir </> "hls")
pure (baseDir `appendGHCupPath` "hls")
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> Version
-> m FilePath
-> m GHCupPath
ghcupHLSDir ver = do
basedir <- ghcupHLSBaseDir
let verdir = T.unpack $ prettyVer ver
pure (basedir </> verdir)
pure (basedir `appendGHCupPath` verdir)
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
@ -296,8 +412,8 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> m FilePath
mkGhcupTmpDir = do
=> m GHCupPath
mkGhcupTmpDir = GHCupPath <$> do
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
@ -333,14 +449,14 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> m FilePath
=> m GHCupPath
withGHCupTmpDir = snd <$> withRunInIO (\run ->
run
$ allocate
(run mkGhcupTmpDir)
(\fp ->
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
$ fp))
@ -381,12 +497,27 @@ cleanupTrash :: ( MonadIO m
=> m ()
cleanupTrash = do
Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory recycleDir
contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
if null contents
then pure ()
else do
logWarn ("Removing leftover files in " <> T.pack recycleDir)
logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir))
forM_ contents (\fp -> handleIO (\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
) where
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
#if IS_WINDOWS
import GHCup.Utils.File.Windows
@ -32,7 +33,6 @@ import GHC.IO ( evaluate )
import Control.Exception.Safe
import Haskus.Utils.Variant.Excepts
import Control.Monad.Reader
import System.Directory hiding (findFiles, copyFile)
import System.FilePath
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.
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 -> FilePath -> m ()) -- ^ file copy operation
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> m [FilePath]
mergeFileTreeAll sourceBase destBase copyOp = do
(force -> !sourceFiles) <- liftIO
@ -54,12 +54,12 @@ mergeFileTreeAll sourceBase destBase copyOp = do
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 -- ^ destination base dir
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> (FilePath -> FilePath -> m ()) -- ^ file copy operation
-> 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
-- 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
import GHCup.Utils.Prelude
import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath )
import GHCup.Types(ProcessError(..), CapturedProcess(..))
import Control.Monad.Reader
@ -16,7 +17,11 @@ import Data.Maybe
import Data.Text ( Text )
import Data.Void
import GHC.IO.Exception
import System.Directory hiding (findFiles, copyFile)
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import System.FilePath
import Text.Regex.Posix
@ -94,7 +99,7 @@ findFiles path regex = do
contents <- listDirectory path
pure $ filter (match regex) contents
findFilesDeep :: FilePath -> Regex -> IO [FilePath]
findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
findFilesDeep path regex = do
contents <- getDirectoryContentsRecursive path
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
import GHCup.Utils.Dirs
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
@ -42,7 +43,6 @@ import GHC.IO.Exception
import System.IO ( stderr, hClose, hSetBinaryMode )
import System.IO.Error
import System.FilePath
import System.Directory hiding ( copyFile )
import System.Posix.Directory
import System.Posix.Error ( throwErrnoPathIfMinus1Retry )
import System.Posix.Internals ( withFilePath )
@ -56,6 +56,7 @@ import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
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.Process as SPP
import qualified System.Posix.IO as SPI
@ -101,7 +102,7 @@ execLogged exe args chdir lfile env = do
Settings {..} <- getSettings
Dirs {..} <- getDirs
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 })
closeFd
(action verbose noColor)
@ -550,3 +551,6 @@ install from to fail' = do
| PF.isSymbolicLink fs = recreateSymlink from to fail'
| 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
import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
import GHCup.Utils.Dirs
import GHCup.Utils.Dirs hiding ( copyFile )
import GHCup.Utils.File.Common
import GHCup.Utils.Logger
import GHCup.Types
@ -32,7 +32,6 @@ import Data.List
import Foreign.C.Error
import GHC.IO.Exception
import GHC.IO.Handle
import System.Directory hiding ( copyFile )
import System.Environment
import System.FilePath
import System.IO
@ -284,3 +283,6 @@ deleteFile = WS.deleteFile
install :: FilePath -> FilePath -> Bool -> IO ()
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.Optics
import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
import GHCup.Utils.String.QQ
@ -117,14 +118,14 @@ initGHCupFileLogging :: ( MonadReader env m
) => m FilePath
initGHCupFileLogging = do
Dirs { logsDir } <- getDirs
let logfile = logsDir </> "ghcup.log"
let logfile = fromGHCupPath logsDir </> "ghcup.log"
logFiles <- liftIO $ findFiles
logsDir
(fromGHCupPath logsDir)
(makeRegexOpts compExtended
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)
liftIO $ writeFile logfile ""
pure logfile

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

@ -27,6 +27,7 @@ module GHCup.Utils.Prelude
)
where
import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory)
import GHCup.Types
import GHCup.Errors
import GHCup.Types.Optics
@ -44,9 +45,8 @@ import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Bifunctor
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.Foldable
import Data.List.NonEmpty ( NonEmpty( (:|) ))
import Data.String
import Data.Text ( Text )
@ -56,9 +56,12 @@ import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
import System.IO.Error
import System.IO.Temp
import System.IO.Unsafe
import System.Directory hiding ( copyFile )
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, copyFile
)
import System.FilePath
import Control.Retry
@ -397,30 +400,6 @@ createDirRecursive' p =
_ -> 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.
--
@ -429,8 +408,12 @@ copyDirectoryRecursive srcDir destDir doCopy = do
-- the source directory structure changes before the list is used.
--
-- TODO: use streamly
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
getDirectoryContentsRecursive :: GHCupPath -> IO [FilePath]
getDirectoryContentsRecursive (fromGHCupPath -> topdir) = getDirectoryContentsRecursiveUnsafe topdir
getDirectoryContentsRecursiveUnsafe :: FilePath -> IO [FilePath]
getDirectoryContentsRecursiveUnsafe topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories [] = return []
@ -464,14 +447,14 @@ recyclePathForcibly :: ( MonadIO m
, HasDirs env
, MonadMask m
)
=> FilePath
=> GHCupPath
-> m ()
recyclePathForcibly fp
| isWindows = do
Dirs { recycleDir } <- getDirs
tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
let dest = tmp </> takeFileName fp
liftIO (moveFile fp dest)
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
`catch`
(\e -> if | isDoesNotExistError e -> pure ()
| isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
@ -484,7 +467,7 @@ recyclePathForcibly fp
rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> FilePath
=> GHCupPath
-> m ()
rmPathForcibly fp
| isWindows = recover (liftIO $ removePathForcibly fp)
@ -492,7 +475,7 @@ rmPathForcibly fp
rmDirectory :: (MonadIO m, MonadMask m)
=> FilePath
=> GHCupPath
-> m ()
rmDirectory fp
| isWindows = recover (liftIO $ removeDirectory fp)
@ -512,11 +495,11 @@ recycleFile fp
| isWindows = do
Dirs { recycleDir } <- getDirs
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
let dest = tmp </> takeFileName fp
tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
let dest = fromGHCupPath tmp </> takeFileName fp
liftIO (moveFile fp dest)
`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`
liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
| otherwise = liftIO $ removeFile fp

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

@ -1,6 +1,10 @@
module GHCup.Utils.Prelude.Posix where
import System.Directory
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import System.Posix.Files