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

297 lines
8.3 KiB
Haskell
Raw 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-01-11 20:15:05 +00:00
{-# LANGUAGE QuasiQuotes #-}
2020-04-25 10:06:41 +00:00
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
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
( getDirs
2021-05-14 21:09:45 +00:00
, ghcupBaseDir
, ghcupConfigFile
, ghcupCacheDir
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.Exception.Safe
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
2020-01-11 20:15:05 +00:00
import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
2020-01-11 20:15:05 +00:00
import Data.Maybe
import Data.String.Interpolate
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
2020-01-11 20:15:05 +00:00
import Optics
#if !defined(IS_WINDOWS)
2021-05-14 21:09:45 +00:00
import System.Directory
#endif
import System.DiskSpace
2021-05-14 21:09:45 +00:00
import System.Environment
import System.FilePath
import System.IO.Temp
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Yaml as Y
2020-04-25 10:06:41 +00:00
import qualified Text.Megaparsec as MP
import Control.Concurrent (threadDelay)
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.
2021-05-14 21:09:45 +00:00
ghcupBaseDir :: IO FilePath
2020-01-11 20:15:05 +00:00
ghcupBaseDir = do
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
pure (bdir </> "ghcup")
2021-05-14 21:09:45 +00:00
#else
2020-07-28 23:43:00 +00:00
xdg <- useXDG
if xdg
then do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
Just r -> pure r
2020-07-28 23:43:00 +00:00
Nothing -> do
home <- liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (home </> ".local" </> "share")
pure (bdir </> "ghcup")
2020-07-28 23:43:00 +00:00
else do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
2020-07-28 23:43:00 +00:00
Nothing -> liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (bdir </> ".ghcup")
#endif
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.
2021-05-14 21:09:45 +00:00
ghcupConfigDir :: IO FilePath
ghcupConfigDir = do
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
ghcupBaseDir
2021-05-14 21:09:45 +00:00
#else
xdg <- useXDG
if xdg
then do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
Just r -> pure r
Nothing -> do
home <- liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (home </> ".config")
pure (bdir </> "ghcup")
else do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
Just r -> pure r
Nothing -> liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (bdir </> ".ghcup")
#endif
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
2020-07-28 23:43:00 +00:00
ghcupBinDir = do
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "bin")
2021-05-14 21:09:45 +00:00
#else
2020-07-28 23:43:00 +00:00
xdg <- useXDG
if xdg
then do
2021-05-14 21:09:45 +00:00
lookupEnv "XDG_BIN_HOME" >>= \case
Just r -> pure r
2020-07-28 23:43:00 +00:00
Nothing -> do
home <- liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (home </> ".local" </> "bin")
else ghcupBaseDir <&> (</> "bin")
#endif
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.
2021-05-14 21:09:45 +00:00
ghcupCacheDir :: IO FilePath
2020-07-28 23:43:00 +00:00
ghcupCacheDir = do
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "cache")
2021-05-14 21:09:45 +00:00
#else
2020-07-28 23:43:00 +00:00
xdg <- useXDG
if xdg
then do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
2020-07-28 23:43:00 +00:00
Nothing -> do
home <- liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (home </> ".cache")
pure (bdir </> "ghcup")
else ghcupBaseDir <&> (</> "cache")
#endif
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.
2021-05-14 21:09:45 +00:00
ghcupLogsDir :: IO FilePath
2020-07-28 23:43:00 +00:00
ghcupLogsDir = do
2021-05-14 21:09:45 +00:00
#if defined(IS_WINDOWS)
ghcupBaseDir <&> (</> "logs")
2021-05-14 21:09:45 +00:00
#else
2020-07-28 23:43:00 +00:00
xdg <- useXDG
if xdg
then do
2021-05-14 21:09:45 +00:00
bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
Just r -> pure r
2020-07-28 23:43:00 +00:00
Nothing -> do
home <- liftIO getHomeDirectory
2021-05-14 21:09:45 +00:00
pure (home </> ".cache")
pure (bdir </> "ghcup" </> "logs")
else ghcupBaseDir <&> (</> "logs")
#endif
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
2021-05-14 21:09:45 +00:00
let file = confDir </> "config.yaml"
contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
case contents of
Nothing -> pure defaultUserSettings
2021-05-14 21:09:45 +00:00
Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
2020-07-31 18:10:40 +00:00
-------------------------
--[ GHCup directories ]--
-------------------------
-- | ~/.ghcup/ghc by default.
2021-05-14 21:09:45 +00:00
ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
2020-07-31 18:10:40 +00:00
ghcupGHCBaseDir = do
2020-10-23 23:06:53 +00:00
AppState { dirs = Dirs {..} } <- ask
2021-05-14 21:09:45 +00:00
pure (baseDir </> "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
2021-05-14 21:09:45 +00:00
-> m FilePath
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
2020-07-31 18:10:40 +00:00
pure (ghcbasedir </> verdir)
-- | 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
2021-05-14 21:09:45 +00:00
mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
2020-01-11 20:15:05 +00:00
mkGhcupTmpDir = do
2021-05-14 21:09:45 +00:00
tmpdir <- liftIO getCanonicalTemporaryDirectory
2021-04-25 19:32:58 +00:00
let minSpace = 5000 -- a rough guess, aight?
2021-05-14 21:09:45 +00:00
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do
2021-05-14 21:09:45 +00:00
$(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
$(logWarn)
"...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene
2021-05-14 21:09:45 +00:00
liftIO $ createTempDirectory tmpdir "ghcup"
where
toBytes mb = mb * 1024 * 1024
toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
truncate' :: Double -> Int -> Double
2021-04-25 16:00:32 +00:00
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
2020-01-11 20:15:05 +00:00
2021-05-14 21:09:45 +00:00
withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
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 ]--
--------------
2021-05-14 21:09:45 +00:00
#if !defined(IS_WINDOWS)
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"
#endif
2020-07-28 23:43:00 +00:00
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 =
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) "..")
2021-05-14 21:09:45 +00:00
<> joinPath ([pathSeparator] : drop (length common) d2)
2020-07-28 23:43:00 +00:00