{-# 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 -- 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 -- uhm , rmPathForcibly ) where import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) 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 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 --------------------------- --[ 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")) 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 | 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")) -- | '~/.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' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings Just contents' -> lE' JSONDecodeError . first 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/'. -- 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 -- | ~/.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/' 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 = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (\fp -> handleIO (\e -> run $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) . rmPathForcibly $ 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)) -- 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 rmPathForcibly :: ( MonadIO m , MonadMask m ) => GHCupPath -> m () rmPathForcibly fp | isWindows = recover (liftIO $ removePathForcibly fp) | otherwise = liftIO $ removePathForcibly fp