ghcup-hs/lib/GHCup/Utils/Dirs.hs

547 lines
16 KiB
Haskell
Raw Permalink Normal View History

2021-05-14 21:09:45 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-07-31 18:10:40 +00:00
{-# LANGUAGE FlexibleContexts #-}
2020-04-25 10:06:41 +00:00
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}
2020-01-11 20:15:05 +00:00
2020-07-21 23:08:58 +00:00
{-|
Module : GHCup.Utils.Dirs
Description : Definition of GHCup directories
Copyright : (c) Julian Ospald, 2020
2020-07-30 18:04:02 +00:00
License : LGPL-3.0
2020-07-21 23:08:58 +00:00
Maintainer : hasufell@hasufell.de
Stability : experimental
2021-05-14 21:09:45 +00:00
Portability : portable
2020-07-21 23:08:58 +00:00
-}
2020-07-31 18:10:40 +00:00
module GHCup.Utils.Dirs
( getAllDirs
2021-05-14 21:09:45 +00:00
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
2020-07-31 18:10:40 +00:00
, ghcupGHCBaseDir
, ghcupGHCDir
2022-02-05 00:53:04 +00:00
, ghcupHLSBaseDir
, ghcupHLSDir
2020-07-31 18:10:40 +00:00
, mkGhcupTmpDir
, parseGHCupGHCDir
2022-02-05 00:53:04 +00:00
, parseGHCupHLSDir
2020-07-31 18:10:40 +00:00
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
, useXDG
2021-07-22 13:45:08 +00:00
, 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
2020-07-31 18:10:40 +00:00
)
where
2020-01-11 20:15:05 +00:00
import GHCup.Errors
2020-04-25 10:06:41 +00:00
import GHCup.Types
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
2022-05-21 20:54:18 +00:00
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
2020-01-11 20:15:05 +00:00
import Control.DeepSeq (NFData, rnf)
2020-01-11 20:15:05 +00:00
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.List
import Data.ByteString ( ByteString )
import Data.Bifunctor
2020-01-11 20:15:05 +00:00
import Data.Maybe
2022-02-05 00:53:04 +00:00
import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
2020-01-11 20:15:05 +00:00
import Optics
2022-05-14 15:58:11 +00:00
import Safe
import System.Directory hiding ( removeDirectory
, removeDirectoryRecursive
, removePathForcibly
, findFiles
)
import qualified System.Directory as SD
2021-05-14 21:09:45 +00:00
import System.Environment
import System.FilePath
import System.IO.Temp
import Text.Regex.Posix
2021-05-14 21:09:45 +00:00
import qualified Data.ByteString as BS
import qualified Data.Text as T
2021-10-21 21:17:26 +00:00
import qualified Data.Yaml.Aeson as Y
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
2022-05-21 20:54:18 +00:00
import System.IO.Error (ioeGetErrorType)
2020-01-11 20:15:05 +00:00
---------------------------
--[ 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
2022-05-20 21:19:33 +00:00
tmpdir <- fromGHCupPath <$> ghcupTMPDir
ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
tmpdir
(makeRegexOpts compExtended
execBlank
([s|^ghcup-.*$|] :: ByteString)
)
2022-05-14 15:58:11 +00:00
pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)
2020-07-31 18:10:40 +00:00
------------------------------
--[ GHCup base directories ]--
------------------------------
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
-- | ~/.ghcup by default
2020-07-28 23:43:00 +00:00
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
ghcupBaseDir :: IO GHCupPath
2021-10-17 18:39:49 +00:00
ghcupBaseDir
| isWindows = do
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (GHCupPath (bdir </> "ghcup"))
2021-10-17 18:39:49 +00:00
| 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"))
2021-10-17 18:39:49 +00:00
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (GHCupPath (bdir </> ".ghcup"))
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
-- | ~/.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
2021-10-17 18:39:49 +00:00
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"))
2021-10-17 18:39:49 +00:00
else do
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
pure (GHCupPath (bdir </> ".ghcup"))
2020-07-28 23:43:00 +00:00
-- | 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).
2021-05-14 21:09:45 +00:00
ghcupBinDir :: IO FilePath
2021-10-17 18:39:49 +00:00
ghcupBinDir
| isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
2021-10-17 18:39:49 +00:00
| 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")
2020-07-28 23:43:00 +00:00
2020-07-31 18:10:40 +00:00
2020-07-28 23:43:00 +00:00
-- | 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
2021-10-17 18:39:49 +00:00
ghcupCacheDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
2021-10-17 18:39:49 +00:00
| 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"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
2020-07-28 23:43:00 +00:00
2020-07-31 18:10:40 +00:00
2020-07-28 23:43:00 +00:00
-- | 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
2021-10-17 18:39:49 +00:00
ghcupLogsDir
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
2021-10-17 18:39:49 +00:00
| 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"))
2020-01-11 20:15:05 +00:00
-- | 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
| isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
| 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" </> "db"))
else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
2021-07-22 13:45:08 +00:00
-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO GHCupPath
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
2022-05-20 21:19:33 +00:00
-- | 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
2021-07-22 13:45:08 +00:00
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
recycleDir <- ghcupRecycleDir
2022-05-20 21:19:33 +00:00
tmpDir <- ghcupTMPDir
dbDir <- ghcupDbDir
2020-07-31 18:10:40 +00:00
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
2022-05-21 20:54:18 +00:00
contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
2021-05-14 21:09:45 +00:00
case contents of
Nothing -> pure defaultUserSettings
2022-05-21 20:54:18 +00:00
Just contents' -> liftE
. veitherToExcepts @_ @'[JSONError]
. either (VLeft . V) VRight
. first (JSONDecodeError . displayException)
. Y.decodeEither'
$ contents'
2020-07-31 18:10:40 +00:00
-------------------------
--[ GHCup directories ]--
-------------------------
-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
2020-07-31 18:10:40 +00:00
ghcupGHCBaseDir = do
Dirs {..} <- getDirs
pure (baseDir `appendGHCupPath` "ghc")
2020-07-31 18:10:40 +00:00
-- | 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)
2020-07-31 18:10:40 +00:00
=> GHCTargetVersion
-> m GHCupPath
2020-07-31 18:10:40 +00:00
ghcupGHCDir ver = do
2021-05-14 21:09:45 +00:00
ghcbasedir <- ghcupGHCBaseDir
let verdir = T.unpack $ tVerToText ver
pure (ghcbasedir `appendGHCupPath` verdir)
2020-07-31 18:10:40 +00:00
-- | See 'ghcupToolParser'.
2021-05-14 21:09:45 +00:00
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
2020-07-31 18:10:40 +00:00
throwEither $ MP.parse ghcTargetVerP "" fp
2022-02-05 00:53:04 +00:00
parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
parseGHCupHLSDir (T.pack -> fp) =
throwEither $ MP.parse version' "" fp
2022-05-21 20:54:18 +00:00
-- 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
2022-02-05 00:53:04 +00:00
-- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
2022-02-05 00:53:04 +00:00
ghcupHLSBaseDir = do
Dirs {..} <- getDirs
pure (baseDir `appendGHCupPath` "hls")
2022-02-05 00:53:04 +00:00
-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
=> Version
-> m GHCupPath
2022-02-05 00:53:04 +00:00
ghcupHLSDir ver = do
basedir <- ghcupHLSBaseDir
let verdir = T.unpack $ prettyVer ver
pure (basedir `appendGHCupPath` verdir)
2020-07-31 18:10:40 +00:00
2022-05-20 21:19:33 +00:00
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
, MonadUnliftIO m
2021-08-30 20:41:58 +00:00
, HasLog env
, MonadCatch m
, MonadThrow m
, MonadMask m
, MonadIO m)
=> m GHCupPath
mkGhcupTmpDir = GHCupPath <$> do
2022-05-20 21:19:33 +00:00
Dirs { tmpDir } <- getDirs
liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
2020-01-11 20:15:05 +00:00
withGHCupTmpDir :: ( MonadReader env m
, HasDirs env
2021-08-30 20:41:58 +00:00
, 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))
2020-01-11 20:15:05 +00:00
2020-07-31 18:10:40 +00:00
2020-01-11 20:15:05 +00:00
--------------
--[ Others ]--
--------------
2020-07-28 23:43:00 +00:00
useXDG :: IO Bool
2021-05-14 21:09:45 +00:00
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
2020-07-28 23:43:00 +00:00
-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks.
2021-05-14 21:09:45 +00:00
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)
2020-07-28 23:43:00 +00:00
2021-07-22 13:45:08 +00:00
cleanupTrash :: ( MonadIO m
, MonadMask m
, MonadReader env m
2021-08-30 20:41:58 +00:00
, HasLog env
2021-07-22 13:45:08 +00:00
, HasDirs env
2021-08-30 20:41:58 +00:00
, HasSettings env
2021-07-22 13:45:08 +00:00
)
=> 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))
2021-07-22 13:45:08 +00:00
forM_ contents (\fp -> handleIO (\e ->
2021-08-30 20:41:58 +00:00
logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ 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
2022-05-20 21:19:33 +00:00
2021-07-22 13:45:08 +00:00