274 lines
7.6 KiB
Haskell
274 lines
7.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
{-|
|
|
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 : POSIX
|
|
-}
|
|
module GHCup.Utils.Dirs
|
|
( getDirs
|
|
, ghcupConfigFile
|
|
, ghcupGHCBaseDir
|
|
, ghcupGHCDir
|
|
, mkGhcupTmpDir
|
|
, parseGHCupGHCDir
|
|
, relativeSymlink
|
|
, withGHCupTmpDir
|
|
)
|
|
where
|
|
|
|
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Types.JSON ( )
|
|
import GHCup.Utils.MegaParsec
|
|
import GHCup.Utils.Prelude
|
|
|
|
import Control.Applicative
|
|
import Control.Exception.Safe
|
|
import Control.Monad
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Resource
|
|
import Data.Bifunctor
|
|
import Data.ByteString ( ByteString )
|
|
import Data.Maybe
|
|
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
|
|
import Haskus.Utils.Variant.Excepts
|
|
import HPath
|
|
import HPath.IO
|
|
import Optics
|
|
import Prelude hiding ( abs
|
|
, readFile
|
|
, writeFile
|
|
)
|
|
import System.Posix.Env.ByteString ( getEnv
|
|
, getEnvDefault
|
|
)
|
|
import System.Posix.FilePath hiding ( (</>) )
|
|
import System.Posix.Temp.ByteString ( mkdtemp )
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString.UTF8 as UTF8
|
|
import qualified Data.Text.Encoding as E
|
|
import qualified Data.Yaml as Y
|
|
import qualified System.Posix.FilePath as FP
|
|
import qualified System.Posix.User as PU
|
|
import qualified Text.Megaparsec as MP
|
|
|
|
|
|
|
|
------------------------------
|
|
--[ 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 (Path Abs)
|
|
ghcupBaseDir = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- getEnv "XDG_DATA_HOME" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> [rel|.local/share|])
|
|
pure (bdir </> [rel|ghcup|])
|
|
else do
|
|
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> liftIO getHomeDirectory
|
|
pure (bdir </> [rel|.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 (Path Abs)
|
|
ghcupConfigDir = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> [rel|.config|])
|
|
pure (bdir </> [rel|ghcup|])
|
|
else do
|
|
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> liftIO getHomeDirectory
|
|
pure (bdir </> [rel|.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 (Path Abs)
|
|
ghcupBinDir = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
getEnv "XDG_BIN_HOME" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> [rel|.local/bin|])
|
|
else ghcupBaseDir <&> (</> [rel|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 (Path Abs)
|
|
ghcupCacheDir = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> [rel|.cache|])
|
|
pure (bdir </> [rel|ghcup|])
|
|
else ghcupBaseDir <&> (</> [rel|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 (Path Abs)
|
|
ghcupLogsDir = do
|
|
xdg <- useXDG
|
|
if xdg
|
|
then do
|
|
bdir <- getEnv "XDG_CACHE_HOME" >>= \case
|
|
Just r -> parseAbs r
|
|
Nothing -> do
|
|
home <- liftIO getHomeDirectory
|
|
pure (home </> [rel|.cache|])
|
|
pure (bdir </> [rel|ghcup/logs|])
|
|
else ghcupBaseDir <&> (</> [rel|logs|])
|
|
|
|
|
|
getDirs :: IO Dirs
|
|
getDirs = do
|
|
baseDir <- ghcupBaseDir
|
|
binDir <- ghcupBinDir
|
|
cacheDir <- ghcupCacheDir
|
|
logsDir <- ghcupLogsDir
|
|
confDir <- ghcupConfigDir
|
|
pure Dirs { .. }
|
|
|
|
|
|
|
|
-------------------
|
|
--[ GHCup files ]--
|
|
-------------------
|
|
|
|
|
|
ghcupConfigFile :: (MonadIO m)
|
|
=> Excepts '[JSONError] m UserSettings
|
|
ghcupConfigFile = do
|
|
confDir <- liftIO $ ghcupConfigDir
|
|
let file = confDir </> [rel|config.yaml|]
|
|
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file
|
|
case bs of
|
|
Nothing -> pure defaultUserSettings
|
|
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'
|
|
|
|
|
|
-------------------------
|
|
--[ GHCup directories ]--
|
|
-------------------------
|
|
|
|
|
|
-- | ~/.ghcup/ghc by default.
|
|
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
|
|
ghcupGHCBaseDir = do
|
|
AppState { dirs = Dirs {..} } <- ask
|
|
pure (baseDir </> [rel|ghc|])
|
|
|
|
|
|
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
|
|
-- The dir may be of the form
|
|
-- * armv7-unknown-linux-gnueabihf-8.8.3
|
|
-- * 8.8.4
|
|
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
|
|
=> GHCTargetVersion
|
|
-> m (Path Abs)
|
|
ghcupGHCDir ver = do
|
|
ghcbasedir <- ghcupGHCBaseDir
|
|
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
|
|
pure (ghcbasedir </> verdir)
|
|
|
|
|
|
-- | See 'ghcupToolParser'.
|
|
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
|
|
parseGHCupGHCDir (toFilePath -> f) = do
|
|
fp <- throwEither $ E.decodeUtf8' f
|
|
throwEither $ MP.parse ghcTargetVerP "" fp
|
|
|
|
|
|
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
|
mkGhcupTmpDir = do
|
|
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
|
|
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
|
|
parseAbs tmp
|
|
|
|
|
|
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
|
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Others ]--
|
|
--------------
|
|
|
|
|
|
getHomeDirectory :: IO (Path Abs)
|
|
getHomeDirectory = do
|
|
e <- getEnv "HOME"
|
|
case e of
|
|
Just fp -> parseAbs fp
|
|
Nothing -> do
|
|
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
|
parseAbs $ UTF8.fromString h -- this is a guess
|
|
|
|
|
|
useXDG :: IO Bool
|
|
useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
|
|
|
|
|
|
relativeSymlink :: Path Abs -- ^ the path in which to create the symlink
|
|
-> Path Abs -- ^ the symlink destination
|
|
-> ByteString
|
|
relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
|
|
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 ("/" : (drop (length common) d2))
|
|
|
|
|
|
|
|
|