{-# 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 :: IO (Path Abs)
ghcupBaseDir = do
  Bool
xdg <- IO Bool
useXDG
  if Bool
xdg
    then do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"XDG_DATA_HOME" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> do
          Path Abs
home <- IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
          Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
home Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|.local/share|])
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|ghcup|])
    else do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"GHCUP_INSTALL_BASE_PREFIX" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [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 :: IO (Path Abs)
ghcupConfigDir = do
  Bool
xdg <- IO Bool
useXDG
  if Bool
xdg
    then do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"XDG_CONFIG_HOME" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> do
          Path Abs
home <- IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
          Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
home Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|.config|])
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|ghcup|])
    else do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"GHCUP_INSTALL_BASE_PREFIX" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [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 :: IO (Path Abs)
ghcupBinDir = do
  Bool
xdg <- IO Bool
useXDG
  if Bool
xdg
    then do
      ByteString -> IO (Maybe ByteString)
getEnv ByteString
"XDG_BIN_HOME" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> do
          Path Abs
home <- IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
          Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
home Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|.local/bin|])
    else IO (Path Abs)
ghcupBaseDir IO (Path Abs) -> (Path Abs -> Path Abs) -> IO (Path Abs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [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 :: IO (Path Abs)
ghcupCacheDir = do
  Bool
xdg <- IO Bool
useXDG
  if Bool
xdg
    then do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"XDG_CACHE_HOME" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> do
          Path Abs
home <- IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
          Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
home Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|.cache|])
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|ghcup|])
    else IO (Path Abs)
ghcupBaseDir IO (Path Abs) -> (Path Abs -> Path Abs) -> IO (Path Abs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [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 :: IO (Path Abs)
ghcupLogsDir = do
  Bool
xdg <- IO Bool
useXDG
  if Bool
xdg
    then do
      Path Abs
bdir <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"XDG_CACHE_HOME" IO (Maybe ByteString)
-> (Maybe ByteString -> IO (Path Abs)) -> IO (Path Abs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ByteString
r  -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
r
        Maybe ByteString
Nothing -> do
          Path Abs
home <- IO (Path Abs) -> IO (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
getHomeDirectory
          Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
home Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|.cache|])
      Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
bdir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|ghcup/logs|])
    else IO (Path Abs)
ghcupBaseDir IO (Path Abs) -> (Path Abs -> Path Abs) -> IO (Path Abs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|logs|])


getDirs :: IO Dirs
getDirs :: IO Dirs
getDirs = do
  Path Abs
baseDir  <- IO (Path Abs)
ghcupBaseDir
  Path Abs
binDir   <- IO (Path Abs)
ghcupBinDir
  Path Abs
cacheDir <- IO (Path Abs)
ghcupCacheDir
  Path Abs
logsDir  <- IO (Path Abs)
ghcupLogsDir
  Path Abs
confDir  <- IO (Path Abs)
ghcupConfigDir
  Dirs -> IO Dirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dirs :: Path Abs -> Path Abs -> Path Abs -> Path Abs -> Path Abs -> Dirs
Dirs { Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
.. }



    -------------------
    --[ GHCup files ]--
    -------------------


ghcupConfigFile :: (MonadIO m)
                => Excepts '[JSONError] m UserSettings
ghcupConfigFile :: Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
  Path Abs
confDir <- IO (Path Abs) -> Excepts '[JSONError] m (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Path Abs)
ghcupConfigDir
  let file :: Path Abs
file = Path Abs
confDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [rel|config.yaml|]
  Maybe ByteString
bs <- IO (Maybe ByteString) -> Excepts '[JSONError] m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString)
 -> Excepts '[JSONError] m (Maybe ByteString))
-> IO (Maybe ByteString)
-> Excepts '[JSONError] m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> (IOException -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
-> IO (Maybe ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
IOErrorType -> (IOException -> m a) -> m a -> m a
handleIO' IOErrorType
NoSuchThing (\IOException
_ -> Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing) (IO (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs -> IO ByteString
forall b. Path b -> IO ByteString
readFile Path Abs
file
  case Maybe ByteString
bs of
      Maybe ByteString
Nothing -> UserSettings -> Excepts '[JSONError] m UserSettings
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserSettings
defaultUserSettings
      Just ByteString
bs' -> (String -> JSONError)
-> Either String UserSettings
-> Excepts '[JSONError] m UserSettings
forall e' e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
(e' -> e) -> Either e' a -> Excepts es m a
lE' String -> JSONError
JSONDecodeError (Either String UserSettings -> Excepts '[JSONError] m UserSettings)
-> (ByteString -> Either String UserSettings)
-> ByteString
-> Excepts '[JSONError] m UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseException -> String)
-> Either ParseException UserSettings -> Either String UserSettings
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException UserSettings -> Either String UserSettings)
-> (ByteString -> Either ParseException UserSettings)
-> ByteString
-> Either String UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException UserSettings
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' (ByteString -> Either ParseException UserSettings)
-> (ByteString -> ByteString)
-> ByteString
-> Either ParseException UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict (ByteString -> Excepts '[JSONError] m UserSettings)
-> ByteString -> Excepts '[JSONError] m UserSettings
forall a b. (a -> b) -> a -> b
$ ByteString
bs'


    -------------------------
    --[ GHCup directories ]--
    -------------------------


-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
ghcupGHCBaseDir :: m (Path Abs)
ghcupGHCBaseDir = do
  AppState { dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
..} } <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Abs -> m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
baseDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> [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 :: GHCTargetVersion -> m (Path Abs)
ghcupGHCDir GHCTargetVersion
ver = do
  Path Abs
ghcbasedir    <- m (Path Abs)
forall (m :: * -> *). MonadReader AppState m => m (Path Abs)
ghcupGHCBaseDir
  Path Rel
verdir        <- ByteString -> m (Path Rel)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Rel)
parseRel (ByteString -> m (Path Rel)) -> ByteString -> m (Path Rel)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
E.encodeUtf8 (GHCTargetVersion -> Text
tVerToText GHCTargetVersion
ver)
  Path Abs -> m (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs
ghcbasedir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
verdir)


-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
parseGHCupGHCDir :: Path Rel -> m GHCTargetVersion
parseGHCupGHCDir (Path Rel -> ByteString
forall b. Path b -> ByteString
toFilePath -> ByteString
f) = do
  Text
fp <- Either UnicodeException Text -> m Text
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either UnicodeException Text -> m Text)
-> Either UnicodeException Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
E.decodeUtf8' ByteString
f
  Either (ParseErrorBundle Text Void) GHCTargetVersion
-> m GHCTargetVersion
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) GHCTargetVersion
 -> m GHCTargetVersion)
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
-> m GHCTargetVersion
forall a b. (a -> b) -> a -> b
$ Parsec Void Text GHCTargetVersion
-> String
-> Text
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text GHCTargetVersion
ghcTargetVerP String
"" Text
fp


mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir :: m (Path Abs)
mkGhcupTmpDir = do
  ByteString
tmpdir <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> IO ByteString
getEnvDefault ByteString
"TMPDIR" ByteString
"/tmp"
  ByteString
tmp    <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
mkdtemp (ByteString
tmpdir ByteString -> ByteString -> ByteString
FP.</> ByteString
"ghcup-")
  ByteString -> m (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
tmp


withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir :: m (Path Abs)
withGHCupTmpDir = (ReleaseKey, Path Abs) -> Path Abs
forall a b. (a, b) -> b
snd ((ReleaseKey, Path Abs) -> Path Abs)
-> m (ReleaseKey, Path Abs) -> m (Path Abs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Path Abs) -> (Path Abs -> IO ()) -> m (ReleaseKey, Path Abs)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO (Path Abs)
forall (m :: * -> *). (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir Path Abs -> IO ()
forall b. Path b -> IO ()
deleteDirRecursive




    --------------
    --[ Others ]--
    --------------


getHomeDirectory :: IO (Path Abs)
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
  Maybe ByteString
e <- ByteString -> IO (Maybe ByteString)
getEnv ByteString
"HOME"
  case Maybe ByteString
e of
    Just ByteString
fp -> ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs ByteString
fp
    Maybe ByteString
Nothing -> do
      String
h <- UserEntry -> String
PU.homeDirectory (UserEntry -> String) -> IO UserEntry -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO UserID
PU.getEffectiveUserID IO UserID -> (UserID -> IO UserEntry) -> IO UserEntry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UserID -> IO UserEntry
PU.getUserEntryForID)
      ByteString -> IO (Path Abs)
forall (m :: * -> *). MonadThrow m => ByteString -> m (Path Abs)
parseAbs (ByteString -> IO (Path Abs)) -> ByteString -> IO (Path Abs)
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString String
h -- this is a guess


useXDG :: IO Bool
useXDG :: IO Bool
useXDG = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> IO (Maybe ByteString) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Maybe ByteString)
getEnv ByteString
"GHCUP_USE_XDG_DIRS"


relativeSymlink :: Path Abs  -- ^ the path in which to create the symlink
                -> Path Abs  -- ^ the symlink destination
                -> ByteString
relativeSymlink :: Path Abs -> Path Abs -> ByteString
relativeSymlink (Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath -> ByteString
p1) (Path Abs -> ByteString
forall b. Path b -> ByteString
toFilePath -> ByteString
p2) =
  let d1 :: [ByteString]
d1      = ByteString -> [ByteString]
splitDirectories ByteString
p1
      d2 :: [ByteString]
d2      = ByteString -> [ByteString]
splitDirectories ByteString
p2
      common :: [(ByteString, ByteString)]
common  = ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(ByteString
x, ByteString
y) -> ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
y) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
d1 [ByteString]
d2
      cPrefix :: [ByteString]
cPrefix = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop ([(ByteString, ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
common) [ByteString]
d1
  in  [ByteString] -> ByteString
joinPath (Int -> ByteString -> [ByteString]
forall a. Int -> a -> [a]
replicate ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
cPrefix) ByteString
"..")
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
joinPath (ByteString
"/" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop ([(ByteString, ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
common) [ByteString]
d2)