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

110 lines
3.1 KiB
Haskell
Raw Permalink Normal View History

2020-03-21 21:19:37 +00:00
{-# LANGUAGE OverloadedStrings #-}
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
module GHCup.Utils.Dirs where
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.Maybe
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.UTF8 as UTF8
2020-04-25 10:06:41 +00:00
import qualified Data.Text.Encoding as E
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
-------------------------
--[ GHCup directories ]--
-------------------------
2020-04-25 10:06:41 +00:00
-- | ~/.ghcup by default
2020-01-11 20:15:05 +00:00
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
2020-01-11 20:15:05 +00:00
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/ghc by default.
2020-01-11 20:15:05 +00:00
ghcupGHCBaseDir :: IO (Path Abs)
2020-03-16 09:47:09 +00:00
ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form
-- * armv7-unknown-linux-gnueabihf-8.8.3
-- * 8.8.4
ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
2020-01-11 20:15:05 +00:00
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
2020-04-25 10:06:41 +00:00
verdir <- parseRel $ E.encodeUtf8 (prettyTVer ver)
2020-01-11 20:15:05 +00:00
pure (ghcbasedir </> verdir)
2020-04-25 10:06:41 +00:00
-- | 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
ghcupBinDir :: IO (Path Abs)
2020-03-16 09:47:09 +00:00
ghcupBinDir = ghcupBaseDir <&> (</> [rel|bin|])
2020-01-11 20:15:05 +00:00
ghcupCacheDir :: IO (Path Abs)
2020-03-16 09:47:09 +00:00
ghcupCacheDir = ghcupBaseDir <&> (</> [rel|cache|])
2020-01-11 20:15:05 +00:00
ghcupLogsDir :: IO (Path Abs)
2020-03-16 09:47:09 +00:00
ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
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
--------------
--[ 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