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

274 lines
7.6 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds #-}
2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-07-31 18:10:40 +00:00
{-# LANGUAGE FlexibleContexts #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
2020-04-25 10:06:41 +00:00
{-# LANGUAGE ViewPatterns #-}
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
Portability : POSIX
-}
2020-07-31 18:10:40 +00:00
module GHCup.Utils.Dirs
( getDirs
, ghcupConfigFile
2020-07-31 18:10:40 +00:00
, ghcupGHCBaseDir
, ghcupGHCDir
, mkGhcupTmpDir
, parseGHCupGHCDir
2020-07-31 18:10:40 +00:00
, relativeSymlink
, withGHCupTmpDir
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 ( )
2020-04-25 10:06:41 +00:00
import GHCup.Utils.MegaParsec
2020-01-11 20:15:05 +00:00
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
2020-07-28 23:43:00 +00:00
import Data.ByteString ( ByteString )
2020-01-11 20:15:05 +00:00
import Data.Maybe
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
2020-01-11 20:15:05 +00:00
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
2020-07-31 18:10:40 +00:00
import System.Posix.FilePath hiding ( (</>) )
2020-01-11 20:15:05 +00:00
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.Lazy as L
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString.UTF8 as UTF8
2020-04-25 10:06:41 +00:00
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
2020-01-11 20:15:05 +00:00
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
2020-01-11 20:15:05 +00:00
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.
2020-01-11 20:15:05 +00:00
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
2020-07-28 23:43:00 +00:00
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|])
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 (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|])
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).
2020-01-11 20:15:05 +00:00
ghcupBinDir :: IO (Path Abs)
2020-07-28 23:43:00 +00:00
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|])
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.
2020-01-11 20:15:05 +00:00
ghcupCacheDir :: IO (Path Abs)
2020-07-28 23:43:00 +00:00
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|])
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.
2020-01-11 20:15:05 +00:00
ghcupLogsDir :: IO (Path Abs)
2020-07-28 23:43:00 +00:00
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|])
2020-01-11 20:15:05 +00:00
2020-07-31 18:10:40 +00:00
getDirs :: IO Dirs
getDirs = do
baseDir <- ghcupBaseDir
binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir
2020-07-31 18:10:40 +00:00
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'
2020-07-31 18:10:40 +00:00
-------------------------
--[ GHCup directories ]--
-------------------------
-- | ~/.ghcup/ghc by default.
2020-10-23 23:06:53 +00:00
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
2020-07-31 18:10:40 +00:00
ghcupGHCBaseDir = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
pure (baseDir </> [rel|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
2020-10-23 23:06:53 +00:00
ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
2020-07-31 18:10:40 +00:00
=> 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
2020-01-11 20:15:05 +00:00
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
2020-03-21 21:19:37 +00:00
tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
2020-01-11 20:15:05 +00:00
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
2020-07-31 18:10:40 +00:00
2020-01-11 20:15:05 +00:00
--------------
--[ Others ]--
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
2020-03-21 21:19:37 +00:00
e <- getEnv "HOME"
2020-01-11 20:15:05 +00:00
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
2020-07-28 23:43:00 +00:00
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) =
2020-07-31 18:10:40 +00:00
let d1 = splitDirectories p1
d2 = splitDirectories p2
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
cPrefix = drop (length common) d1
2020-07-28 23:43:00 +00:00
in joinPath (replicate (length cPrefix) "..")
<> joinPath ("/" : (drop (length common) d2))