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
21 changed files with 421 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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