{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# 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 : portable
-}
module GHCup.Utils.Dirs
  ( getAllDirs
  , ghcupBaseDir
  , ghcupConfigFile
  , ghcupCacheDir
  , ghcupGHCBaseDir
  , ghcupGHCDir
  , ghcupHLSBaseDir
  , ghcupHLSDir
  , mkGhcupTmpDir
  , parseGHCupGHCDir
  , parseGHCupHLSDir
  , relativeSymlink
  , withGHCupTmpDir
  , getConfigFilePath
  , useXDG
  , cleanupTrash
  )
where


import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.JSON               ( )
import           GHCup.Types.Optics
import           GHCup.Utils.MegaParsec
import           GHCup.Utils.Logger
import           GHCup.Utils.Prelude

import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.IO.Unlift
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource hiding (throwM)
import           Data.Bifunctor
import           Data.Maybe
import           Data.Versions
import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
import           Haskus.Utils.Variant.Excepts
import           Optics
import           System.Directory                                                
import           System.DiskSpace                                                
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.Aeson               as Y
import qualified Text.Megaparsec               as MP
import Control.Concurrent (threadDelay)



    ------------------------------
    --[ 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 FilePath
ghcupBaseDir :: IO FilePath
ghcupBaseDir
  | Bool
isWindows = do
      FilePath
bdir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"C:\\" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHCUP_INSTALL_BASE_PREFIX"
      FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup")
  | Bool
otherwise = do
      Bool
xdg <- IO Bool
useXDG
      if Bool
xdg
        then do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"XDG_DATA_HOME" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> FilePath -> FilePath
</> FilePath
".local" FilePath -> FilePath -> FilePath
</> FilePath
"share")
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup")
        else do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHCUP_INSTALL_BASE_PREFIX" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
".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 FilePath
ghcupConfigDir :: IO FilePath
ghcupConfigDir
  | Bool
isWindows = IO FilePath
ghcupBaseDir
  | Bool
otherwise = do
      Bool
xdg <- IO Bool
useXDG
      if Bool
xdg
        then do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"XDG_CONFIG_HOME" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> FilePath -> FilePath
</> FilePath
".config")
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup")
        else do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHCUP_INSTALL_BASE_PREFIX" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
".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 FilePath
ghcupBinDir :: IO FilePath
ghcupBinDir
  | Bool
isWindows = IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"bin")
  | Bool
otherwise = do
      Bool
xdg <- IO Bool
useXDG
      if Bool
xdg
        then do
          FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"XDG_BIN_HOME" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> FilePath -> FilePath
</> FilePath
".local" FilePath -> FilePath -> FilePath
</> FilePath
"bin")
        else IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"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 FilePath
ghcupCacheDir :: IO FilePath
ghcupCacheDir
  | Bool
isWindows = IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"cache")
  | Bool
otherwise = do
      Bool
xdg <- IO Bool
useXDG
      if Bool
xdg
        then do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"XDG_CACHE_HOME" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> FilePath -> FilePath
</> FilePath
".cache")
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup")
        else IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"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 FilePath
ghcupLogsDir :: IO FilePath
ghcupLogsDir
  | Bool
isWindows = IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"logs")
  | Bool
otherwise = do
      Bool
xdg <- IO Bool
useXDG
      if Bool
xdg
        then do
          FilePath
bdir <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"XDG_CACHE_HOME" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> FilePath -> FilePath
</> FilePath
".cache")
          FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
bdir FilePath -> FilePath -> FilePath
</> FilePath
"ghcup" FilePath -> FilePath -> FilePath
</> FilePath
"logs")
        else IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"logs")


-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir :: IO FilePath
ghcupRecycleDir = IO FilePath
ghcupBaseDir IO FilePath -> (FilePath -> FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> FilePath -> FilePath
</> FilePath
"trash")



getAllDirs :: IO Dirs
getAllDirs :: IO Dirs
getAllDirs = do
  FilePath
baseDir    <- IO FilePath
ghcupBaseDir
  FilePath
binDir     <- IO FilePath
ghcupBinDir
  FilePath
cacheDir   <- IO FilePath
ghcupCacheDir
  FilePath
logsDir    <- IO FilePath
ghcupLogsDir
  FilePath
confDir    <- IO FilePath
ghcupConfigDir
  FilePath
recycleDir <- IO FilePath
ghcupRecycleDir
  Dirs -> IO Dirs
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dirs :: FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Dirs
Dirs { FilePath
$sel:recycleDir:Dirs :: FilePath
$sel:confDir:Dirs :: FilePath
$sel:logsDir:Dirs :: FilePath
$sel:cacheDir:Dirs :: FilePath
$sel:binDir:Dirs :: FilePath
$sel:baseDir:Dirs :: FilePath
recycleDir :: FilePath
confDir :: FilePath
logsDir :: FilePath
cacheDir :: FilePath
binDir :: FilePath
baseDir :: FilePath
.. }



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

getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath :: m FilePath
getConfigFilePath = do
  FilePath
confDir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
ghcupConfigDir
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
"config.yaml"

ghcupConfigFile :: (MonadIO m)
                => Excepts '[JSONError] m UserSettings
ghcupConfigFile :: Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
  FilePath
filepath <- Excepts '[JSONError] m FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getConfigFilePath
  Maybe ByteString
contents <- 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
<$> FilePath -> IO ByteString
BS.readFile FilePath
filepath
  case Maybe ByteString
contents of
      Maybe ByteString
Nothing -> UserSettings -> Excepts '[JSONError] m UserSettings
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserSettings
defaultUserSettings
      Just ByteString
contents' -> (FilePath -> JSONError)
-> Either FilePath 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' FilePath -> JSONError
JSONDecodeError (Either FilePath UserSettings
 -> Excepts '[JSONError] m UserSettings)
-> (ByteString -> Either FilePath UserSettings)
-> ByteString
-> Excepts '[JSONError] m UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseException -> FilePath)
-> Either ParseException UserSettings
-> Either FilePath UserSettings
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> FilePath
forall e. Exception e => e -> FilePath
displayException (Either ParseException UserSettings
 -> Either FilePath UserSettings)
-> (ByteString -> Either ParseException UserSettings)
-> ByteString
-> Either FilePath 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 -> Excepts '[JSONError] m UserSettings)
-> ByteString -> Excepts '[JSONError] m UserSettings
forall a b. (a -> b) -> a -> b
$ ByteString
contents'


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


-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupGHCBaseDir :: m FilePath
ghcupGHCBaseDir = do
  Dirs {FilePath
recycleDir :: FilePath
confDir :: FilePath
logsDir :: FilePath
cacheDir :: FilePath
binDir :: FilePath
baseDir :: FilePath
$sel:recycleDir:Dirs :: Dirs -> FilePath
$sel:confDir:Dirs :: Dirs -> FilePath
$sel:logsDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> FilePath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> FilePath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
"ghc")


-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
-- The dir may be of the form
--   * armv7-unknown-linux-gnueabihf-8.8.3
--   * 8.8.4
ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
            => GHCTargetVersion
            -> m FilePath
ghcupGHCDir :: GHCTargetVersion -> m FilePath
ghcupGHCDir GHCTargetVersion
ver = do
  FilePath
ghcbasedir <- m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m FilePath
ghcupGHCBaseDir
  let verdir :: FilePath
verdir = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ GHCTargetVersion -> Text
tVerToText GHCTargetVersion
ver
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
ghcbasedir FilePath -> FilePath -> FilePath
</> FilePath
verdir)


-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir :: FilePath -> m GHCTargetVersion
parseGHCupGHCDir (FilePath -> Text
T.pack -> Text
fp) =
  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
-> FilePath
-> Text
-> Either (ParseErrorBundle Text Void) GHCTargetVersion
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text GHCTargetVersion
ghcTargetVerP FilePath
"" Text
fp

parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
parseGHCupHLSDir :: FilePath -> m Version
parseGHCupHLSDir (FilePath -> Text
T.pack -> Text
fp) =
  Either (ParseErrorBundle Text Void) Version -> m Version
forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither (Either (ParseErrorBundle Text Void) Version -> m Version)
-> Either (ParseErrorBundle Text Void) Version -> m Version
forall a b. (a -> b) -> a -> b
$ Parsec Void Text Version
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) Version
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text Version
version' FilePath
"" Text
fp

-- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
ghcupHLSBaseDir :: m FilePath
ghcupHLSBaseDir = do
  Dirs {FilePath
recycleDir :: FilePath
confDir :: FilePath
logsDir :: FilePath
cacheDir :: FilePath
binDir :: FilePath
baseDir :: FilePath
$sel:recycleDir:Dirs :: Dirs -> FilePath
$sel:confDir:Dirs :: Dirs -> FilePath
$sel:logsDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> FilePath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> FilePath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
"hls")

-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
            => Version
            -> m FilePath
ghcupHLSDir :: Version -> m FilePath
ghcupHLSDir Version
ver = do
  FilePath
basedir <- m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m FilePath
ghcupHLSBaseDir
  let verdir :: FilePath
verdir = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Version -> Text
prettyVer Version
ver
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
basedir FilePath -> FilePath -> FilePath
</> FilePath
verdir)

mkGhcupTmpDir :: ( MonadReader env m
                 , HasDirs env
                 , MonadUnliftIO m
                 , HasLog env
                 , MonadCatch m
                 , MonadThrow m
                 , MonadMask m
                 , MonadIO m)
              => m FilePath
mkGhcupTmpDir :: m FilePath
mkGhcupTmpDir = do
  FilePath
tmpdir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCanonicalTemporaryDirectory

  let minSpace :: Integer
minSpace = Integer
5000 -- a rough guess, aight?
  Maybe Integer
space <- (IOException -> m (Maybe Integer))
-> m (Maybe Integer) -> m (Maybe Integer)
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> Maybe Integer -> m (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing) (m (Maybe Integer) -> m (Maybe Integer))
-> m (Maybe Integer) -> m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ (Integer -> Maybe Integer) -> m Integer -> m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Maybe Integer
forall a. a -> Maybe a
Just (m Integer -> m (Maybe Integer)) -> m Integer -> m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> m Integer) -> IO Integer -> m Integer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Integer
getAvailSpace FilePath
tmpdir
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer
forall a. Num a => a -> a
toBytes Integer
minSpace Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>) Maybe Integer
space) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text
"Possibly insufficient disk space on "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
tmpdir
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". At least "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
minSpace)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" MB are recommended, but only "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Integral a => a -> Text
toMB (Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Integer
space)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" are free. Consider freeing up disk space or setting TMPDIR env variable.")
    Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn
      Text
"...waiting for 10 seconds before continuing anyway, you can still abort..."
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000 -- give the user a sec to intervene

  IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmpdir FilePath
"ghcup"
 where
  toBytes :: a -> a
toBytes a
mb = a
mb a -> a -> a
forall a. Num a => a -> a -> a
* a
1024 a -> a -> a
forall a. Num a => a -> a -> a
* a
1024
  toMB :: a -> Text
toMB a
b = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Double -> FilePath
forall a. Show a => a -> FilePath
show (Double -> Int -> Double
truncate' (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1024 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1024) :: Double) Int
2)
  truncate' :: Double -> Int -> Double
  truncate' :: Double -> Int -> Double
truncate' Double
x Int
n = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t) :: Integer) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
t
      where t :: Double
t = Double
10Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n


withGHCupTmpDir :: ( MonadReader env m
                   , HasDirs env
                   , HasLog env
                   , HasSettings env
                   , MonadUnliftIO m
                   , MonadCatch m
                   , MonadResource m
                   , MonadThrow m
                   , MonadMask m
                   , MonadIO m)
                => m FilePath
withGHCupTmpDir :: m FilePath
withGHCupTmpDir = (ReleaseKey, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ((ReleaseKey, FilePath) -> FilePath)
-> m (ReleaseKey, FilePath) -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. m a -> IO a) -> IO (ReleaseKey, FilePath))
-> m (ReleaseKey, FilePath)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. m a -> IO a
run ->
  m (ReleaseKey, FilePath) -> IO (ReleaseKey, FilePath)
forall a. m a -> IO a
run
    (m (ReleaseKey, FilePath) -> IO (ReleaseKey, FilePath))
-> m (ReleaseKey, FilePath) -> IO (ReleaseKey, FilePath)
forall a b. (a -> b) -> a -> b
$ IO FilePath -> (FilePath -> IO ()) -> m (ReleaseKey, FilePath)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
        (m FilePath -> IO FilePath
forall a. m a -> IO a
run m FilePath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
 MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m FilePath
mkGhcupTmpDir)
        (\FilePath
fp ->
            (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> m () -> IO ()
forall a. m a -> IO a
run
                (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"Resource cleanup failed for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", error was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e)))
            (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
forall (m :: * -> *). (MonadIO m, MonadMask m) => FilePath -> m ()
rmPathForcibly
            (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
fp))




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


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


-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks.
relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
                -> FilePath  -- ^ the symlink destination
                -> FilePath
relativeSymlink :: FilePath -> FilePath -> FilePath
relativeSymlink FilePath
p1 FilePath
p2
  | Bool
isWindows = FilePath
p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
  | Bool
otherwise =
    let d1 :: [FilePath]
d1      = FilePath -> [FilePath]
splitDirectories FilePath
p1
        d2 :: [FilePath]
d2      = FilePath -> [FilePath]
splitDirectories FilePath
p2
        common :: [(FilePath, FilePath)]
common  = ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(FilePath
x, FilePath
y) -> FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
y) ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
d1 [FilePath]
d2
        cPrefix :: [FilePath]
cPrefix = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop ([(FilePath, FilePath)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FilePath, FilePath)]
common) [FilePath]
d1
    in  [FilePath] -> FilePath
joinPath (Int -> FilePath -> [FilePath]
forall a. Int -> a -> [a]
replicate ([FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
cPrefix) FilePath
"..")
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
joinPath ([Char
pathSeparator] FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop ([(FilePath, FilePath)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FilePath, FilePath)]
common) [FilePath]
d2)


cleanupTrash :: ( MonadIO m
                , MonadMask m
                , MonadReader env m
                , HasLog env
                , HasDirs env
                , HasSettings env
                )
             => m ()
cleanupTrash :: m ()
cleanupTrash = do
  Dirs { FilePath
recycleDir :: FilePath
$sel:recycleDir:Dirs :: Dirs -> FilePath
recycleDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  [FilePath]
contents <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
recycleDir
  if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
contents
  then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else do
    Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (Text
"Removing leftover files in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
recycleDir)
    [FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
contents (\FilePath
fp -> (IOException -> m ()) -> m () -> m ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e ->
        Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"Resource cleanup failed for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", error was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e))
      ) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removePathForcibly (FilePath
recycleDir FilePath -> FilePath -> FilePath
</> FilePath
fp))