561 lines
16 KiB
Haskell
561 lines
16 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
{-|
|
|
Module : GHCup.Utils.Dirs
|
|
Description : Definition of GHCup directories
|
|
Copyright : (c) Julian Ospald, 2020
|
|
License : LGPL-3.0
|
|
Maintainer : hasufell@hasufell.de
|
|
Stability : experimental
|
|
Portability : portable
|
|
-}
|
|
module GHCup.Utils.Dirs
|
|
( getAllDirs
|
|
, ghcupBaseDir
|
|
, ghcupConfigFile
|
|
, ghcupCacheDir
|
|
, ghcupGHCBaseDir
|
|
, ghcupGHCDir
|
|
, ghcupHLSBaseDir
|
|
, ghcupHLSDir
|
|
, mkGhcupTmpDir
|
|
, parseGHCupGHCDir
|
|
, parseGHCupHLSDir
|
|
, relativeSymlink
|
|
, withGHCupTmpDir
|
|
, getConfigFilePath
|
|
, useXDG
|
|
, cleanupTrash
|
|
|
|
, GHCupPath
|
|
, appendGHCupPath
|
|
, fromGHCupPath
|
|
, createTempGHCupDirectory
|
|
, getGHCupTmpDirs
|
|
|
|
, removeDirectory
|
|
, removeDirectoryRecursive
|
|
, removePathForcibly
|
|
|
|
, listDirectoryFiles
|
|
, listDirectoryDirs
|
|
|
|
-- 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
|
|
|
|
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Types.JSON ( )
|
|
import GHCup.Types.Optics
|
|
import GHCup.Prelude.MegaParsec
|
|
import GHCup.Prelude.File.Search
|
|
import GHCup.Prelude.String.QQ
|
|
import GHCup.Prelude.Logger.Internal (logWarn, logDebug)
|
|
#if defined(IS_WINDOWS)
|
|
import GHCup.Prelude.Windows ( isWindows )
|
|
#else
|
|
import GHCup.Prelude.Posix ( isWindows )
|
|
#endif
|
|
|
|
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 hiding ( uncons )
|
|
import Safe
|
|
import System.Directory hiding ( removeDirectory
|
|
, removeDirectoryRecursive
|
|
, removePathForcibly
|
|
, findFiles
|
|
)
|
|
import qualified System.Directory as SD
|
|
|
|
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
|
|
import qualified Data.Yaml.Aeson as Y
|
|
import qualified Text.Megaparsec as MP
|
|
import System.IO.Error (ioeGetErrorType)
|
|
|
|
|
|
|
|
---------------------------
|
|
--[ 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 <- fromGHCupPath <$> ghcupTMPDir
|
|
ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
|
|
tmpdir
|
|
(makeRegexOpts compExtended
|
|
execBlank
|
|
([s|^ghcup-.*$|] :: ByteString)
|
|
)
|
|
pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)
|
|
|
|
|
|
------------------------------
|
|
--[ GHCup base directories ]--
|
|
------------------------------
|
|
|
|
|
|
-- | ~/.ghcup by default
|
|
--
|
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
|
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
|
|
ghcupBaseDir :: IO GHCupPath
|
|
ghcupBaseDir
|
|
| isWindows = do
|
|
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
|
|
pure (GHCupPath (bdir </> "ghcup"))
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".local" </> "share")
|
|
pure (GHCupPath (bdir </> "ghcup"))
|
|
else do
|
|
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> liftIO getHomeDirectory
|
|
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 GHCupPath
|
|
ghcupConfigDir
|
|
| isWindows = ghcupBaseDir
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".config")
|
|
pure (GHCupPath (bdir </> "ghcup"))
|
|
else do
|
|
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> liftIO getHomeDirectory
|
|
pure (GHCupPath (bdir </> ".ghcup"))
|
|
|
|
|
|
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
|
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
|
|
-- (which, sadly is not strictly xdg spec).
|
|
ghcupBinDir :: IO FilePath
|
|
ghcupBinDir
|
|
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
lookupEnv "XDG_BIN_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".local" </> "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 GHCupPath
|
|
ghcupCacheDir
|
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".cache")
|
|
pure (GHCupPath (bdir </> "ghcup" </> "cache"))
|
|
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 GHCupPath
|
|
ghcupLogsDir
|
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".cache")
|
|
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 GHCupPath
|
|
ghcupDbDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
|
|
|
|
|
|
-- | '~/.ghcup/trash'.
|
|
-- Mainly used on windows to improve file removal operations
|
|
ghcupRecycleDir :: IO GHCupPath
|
|
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
|
|
|
|
|
|
-- | Defaults to '~/.ghcup/tmp.
|
|
--
|
|
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
|
|
-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
|
|
ghcupTMPDir :: IO GHCupPath
|
|
ghcupTMPDir
|
|
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
|
|
| otherwise = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
|
|
Just r -> pure r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> ".cache")
|
|
pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
|
|
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
|
|
|
|
|
|
getAllDirs :: IO Dirs
|
|
getAllDirs = do
|
|
baseDir <- ghcupBaseDir
|
|
binDir <- ghcupBinDir
|
|
cacheDir <- ghcupCacheDir
|
|
logsDir <- ghcupLogsDir
|
|
confDir <- ghcupConfigDir
|
|
recycleDir <- ghcupRecycleDir
|
|
tmpDir <- ghcupTMPDir
|
|
dbDir <- ghcupDbDir
|
|
pure Dirs { .. }
|
|
|
|
|
|
|
|
-------------------
|
|
--[ GHCup files ]--
|
|
-------------------
|
|
|
|
getConfigFilePath :: (MonadIO m) => m FilePath
|
|
getConfigFilePath = do
|
|
confDir <- liftIO ghcupConfigDir
|
|
pure $ fromGHCupPath confDir </> "config.yaml"
|
|
|
|
ghcupConfigFile :: (MonadIO m)
|
|
=> Excepts '[JSONError] m UserSettings
|
|
ghcupConfigFile = do
|
|
filepath <- getConfigFilePath
|
|
contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
|
|
case contents of
|
|
Nothing -> pure defaultUserSettings
|
|
Just contents' -> liftE
|
|
. veitherToExcepts @_ @'[JSONError]
|
|
. either (VLeft . V) VRight
|
|
. first (JSONDecodeError . displayException)
|
|
. Y.decodeEither'
|
|
$ contents'
|
|
|
|
|
|
-------------------------
|
|
--[ GHCup directories ]--
|
|
-------------------------
|
|
|
|
|
|
-- | ~/.ghcup/ghc by default.
|
|
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
|
ghcupGHCBaseDir = do
|
|
Dirs {..} <- getDirs
|
|
pure (baseDir `appendGHCupPath` "ghc")
|
|
|
|
|
|
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
|
-- The dir may be of the form
|
|
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
|
-- * 8.8.4
|
|
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
|
=> GHCTargetVersion
|
|
-> m GHCupPath
|
|
ghcupGHCDir ver = do
|
|
ghcbasedir <- ghcupGHCBaseDir
|
|
let verdir = T.unpack $ tVerToText ver
|
|
pure (ghcbasedir `appendGHCupPath` verdir)
|
|
|
|
|
|
-- | See 'ghcupToolParser'.
|
|
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
|
|
parseGHCupGHCDir (T.pack -> fp) =
|
|
throwEither $ MP.parse ghcTargetVerP "" fp
|
|
|
|
parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
|
|
parseGHCupHLSDir (T.pack -> fp) =
|
|
throwEither $ MP.parse version' "" fp
|
|
|
|
-- TODO: inlined from GHCup.Prelude
|
|
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
|
throwEither a = case a of
|
|
Left e -> throwM e
|
|
Right r -> pure r
|
|
|
|
-- | ~/.ghcup/hls by default, for new-style installs.
|
|
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
|
|
ghcupHLSBaseDir = do
|
|
Dirs {..} <- getDirs
|
|
pure (baseDir `appendGHCupPath` "hls")
|
|
|
|
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
|
|
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
|
|
=> Version
|
|
-> m GHCupPath
|
|
ghcupHLSDir ver = do
|
|
basedir <- ghcupHLSBaseDir
|
|
let verdir = T.unpack $ prettyVer ver
|
|
pure (basedir `appendGHCupPath` verdir)
|
|
|
|
|
|
mkGhcupTmpDir :: ( MonadReader env m
|
|
, HasDirs env
|
|
, MonadUnliftIO m
|
|
, HasLog env
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, MonadMask m
|
|
, MonadIO m)
|
|
=> m GHCupPath
|
|
mkGhcupTmpDir = GHCupPath <$> do
|
|
Dirs { tmpDir } <- getDirs
|
|
liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
|
|
|
|
|
|
withGHCupTmpDir :: ( MonadReader env m
|
|
, HasDirs env
|
|
, HasLog env
|
|
, HasSettings env
|
|
, MonadUnliftIO m
|
|
, MonadCatch m
|
|
, MonadResource m
|
|
, MonadThrow m
|
|
, MonadMask m
|
|
, MonadIO m)
|
|
=> m GHCupPath
|
|
withGHCupTmpDir = do
|
|
Settings{keepDirs} <- getSettings
|
|
snd <$> withRunInIO (\run ->
|
|
run
|
|
$ allocate
|
|
(run mkGhcupTmpDir)
|
|
(\fp -> if -- we don't know whether there was a failure, so can only
|
|
-- decide for 'Always'
|
|
| keepDirs == Always -> pure ()
|
|
| otherwise -> handleIO (\e -> run
|
|
$ logDebug ("Resource cleanup failed for "
|
|
<> T.pack (fromGHCupPath fp)
|
|
<> ", error was: "
|
|
<> T.pack (displayException e)))
|
|
. removePathForcibly
|
|
$ fp))
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Others ]--
|
|
--------------
|
|
|
|
|
|
useXDG :: IO Bool
|
|
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
|
|
|
|
|
|
-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks.
|
|
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
|
|
-> FilePath -- ^ the symlink destination
|
|
-> FilePath
|
|
relativeSymlink p1 p2
|
|
| isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
|
|
| otherwise =
|
|
let d1 = splitDirectories p1
|
|
d2 = splitDirectories p2
|
|
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
|
cPrefix = drop (length common) d1
|
|
in joinPath (replicate (length cPrefix) "..")
|
|
<> joinPath ([pathSeparator] : drop (length common) d2)
|
|
|
|
|
|
cleanupTrash :: ( MonadIO m
|
|
, MonadMask m
|
|
, MonadReader env m
|
|
, HasLog env
|
|
, HasDirs env
|
|
, HasSettings env
|
|
)
|
|
=> m ()
|
|
cleanupTrash = do
|
|
Dirs { recycleDir } <- getDirs
|
|
contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
|
|
if null contents
|
|
then pure ()
|
|
else do
|
|
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 `appendGHCupPath` fp))
|
|
|
|
|
|
-- | List *actual files* in a directory, ignoring empty files and a couple
|
|
-- of blacklisted files, such as '.DS_Store' on mac.
|
|
listDirectoryFiles :: FilePath -> IO [FilePath]
|
|
listDirectoryFiles fp = do
|
|
listDirectory fp >>= filterM (doesFileExist . (fp </>)) <&> filter (\fp' -> not (isHidden fp') && not (isBlacklisted fp'))
|
|
|
|
-- | List *actual directories* in a directory, ignoring empty directories and a couple
|
|
-- of blacklisted files, such as '.DS_Store' on mac.
|
|
listDirectoryDirs :: FilePath -> IO [FilePath]
|
|
listDirectoryDirs fp = do
|
|
listDirectory fp >>= filterM (doesDirectoryExist . (fp </>)) <&> filter (\fp' -> not (isHidden fp') && not (isBlacklisted fp'))
|
|
|
|
isHidden :: FilePath -> Bool
|
|
isHidden fp'
|
|
| isWindows = False
|
|
| Just ('.', _) <- uncons fp' = True
|
|
| otherwise = False
|
|
|
|
isBlacklisted :: FilePath -> Bool
|
|
{- HLINT ignore "Use ==" -}
|
|
isBlacklisted fp' = fp' `elem` [".DS_Store"]
|
|
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
|
|
|