{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE QuasiQuotes           #-}

{-|
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
  , getConfigFilePath'
  , useXDG
  , cleanupTrash
  , ghcupMsys2BinDirs
  , ghcupMsys2BinDirs'

  , GHCupPath
  , appendGHCupPath
  , fromGHCupPath
  , createTempGHCupDirectory
  , getGHCupTmpDirs

  , removeDirectory
  , removeDirectoryRecursive
  , removePathForcibly

  , listDirectoryFiles
  , listDirectoryDirs

  -- System.Directory re-exports
  , createDirectory
  , createDirectoryIfMissing
  , renameDirectory
  , listDirectory
  , getDirectoryContents
  , getCurrentDirectory
  , setCurrentDirectory
  , withCurrentDirectory
  , getHomeDirectory
  , XdgDirectory(..)
  , getXdgDirectory
  , XdgDirectoryList(..)
  , getXdgDirectoryList
  , getAppUserDataDirectory
  , getUserDocumentsDirectory
  , getTemporaryDirectory
  , removeFile
  , renameFile
  , renamePath
  , getFileSize
  , canonicalizePath
  , makeAbsolute
  , makeRelativeToCurrentDirectory
  , doesPathExist
  , doesFileExist
  , doesDirectoryExist
  , findExecutable
  , findExecutables
  , findExecutablesInDirectories
  , findFile
  , findFileWith
  , findFilesWith
  , exeExtension
  , createFileLink
  , createDirectoryLink
  , removeDirectoryLink
  , pathIsSymbolicLink
  , getSymbolicLinkTarget
  , Permissions
  , emptyPermissions
  , readable
  , writable
  , executable
  , searchable
  , setOwnerReadable
  , setOwnerWritable
  , setOwnerExecutable
  , setOwnerSearchable
  , getPermissions
  , setPermissions
  , copyPermissions
  , getAccessTime
  , getModificationTime
  , setAccessTime
  , setModificationTime
  , isSymbolicLink
  )
where


import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.JSON               ( )
import           GHCup.Types.Optics
import           GHCup.Prelude.MegaParsec
import           GHCup.Prelude.File.Search
import           GHCup.Prelude.String.QQ
import           GHCup.Prelude.Logger.Internal (logWarn, logDebug)
#if defined(IS_WINDOWS)
import           GHCup.Prelude.Windows ( isWindows )
#else
import           GHCup.Prelude.Posix   ( isWindows )
#endif

import           Control.DeepSeq (NFData, rnf)
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.List
import           Data.ByteString                ( ByteString )
import           Data.Bifunctor
import           Data.Maybe
import           Data.Versions
import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
import           Haskus.Utils.Variant.Excepts
import           Optics hiding ( uncons )
import           Safe
import           System.Info
import           System.Directory hiding ( removeDirectory
                                         , removeDirectoryRecursive
                                         , removePathForcibly
                                         , findFiles
                                         )
import qualified System.Directory              as SD

import           System.Environment
import           System.FilePath
import           System.IO.Temp
import           Text.Regex.Posix

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 System.IO.Error (ioeGetErrorType)



    ---------------------------
    --[ GHCupPath utilities ]--
    ---------------------------

-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.
--
-- The constructor is not exported.
newtype GHCupPath = GHCupPath FilePath
  deriving (Int -> GHCupPath -> ShowS
[GHCupPath] -> ShowS
GHCupPath -> FilePath
(Int -> GHCupPath -> ShowS)
-> (GHCupPath -> FilePath)
-> ([GHCupPath] -> ShowS)
-> Show GHCupPath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GHCupPath -> ShowS
showsPrec :: Int -> GHCupPath -> ShowS
$cshow :: GHCupPath -> FilePath
show :: GHCupPath -> FilePath
$cshowList :: [GHCupPath] -> ShowS
showList :: [GHCupPath] -> ShowS
Show, GHCupPath -> GHCupPath -> Bool
(GHCupPath -> GHCupPath -> Bool)
-> (GHCupPath -> GHCupPath -> Bool) -> Eq GHCupPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GHCupPath -> GHCupPath -> Bool
== :: GHCupPath -> GHCupPath -> Bool
$c/= :: GHCupPath -> GHCupPath -> Bool
/= :: GHCupPath -> GHCupPath -> Bool
Eq, Eq GHCupPath
Eq GHCupPath
-> (GHCupPath -> GHCupPath -> Ordering)
-> (GHCupPath -> GHCupPath -> Bool)
-> (GHCupPath -> GHCupPath -> Bool)
-> (GHCupPath -> GHCupPath -> Bool)
-> (GHCupPath -> GHCupPath -> Bool)
-> (GHCupPath -> GHCupPath -> GHCupPath)
-> (GHCupPath -> GHCupPath -> GHCupPath)
-> Ord GHCupPath
GHCupPath -> GHCupPath -> Bool
GHCupPath -> GHCupPath -> Ordering
GHCupPath -> GHCupPath -> GHCupPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GHCupPath -> GHCupPath -> Ordering
compare :: GHCupPath -> GHCupPath -> Ordering
$c< :: GHCupPath -> GHCupPath -> Bool
< :: GHCupPath -> GHCupPath -> Bool
$c<= :: GHCupPath -> GHCupPath -> Bool
<= :: GHCupPath -> GHCupPath -> Bool
$c> :: GHCupPath -> GHCupPath -> Bool
> :: GHCupPath -> GHCupPath -> Bool
$c>= :: GHCupPath -> GHCupPath -> Bool
>= :: GHCupPath -> GHCupPath -> Bool
$cmax :: GHCupPath -> GHCupPath -> GHCupPath
max :: GHCupPath -> GHCupPath -> GHCupPath
$cmin :: GHCupPath -> GHCupPath -> GHCupPath
min :: GHCupPath -> GHCupPath -> GHCupPath
Ord)

instance NFData GHCupPath where
  rnf :: GHCupPath -> ()
rnf (GHCupPath FilePath
fp) = FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
fp

appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
appendGHCupPath (GHCupPath FilePath
gp) FilePath
fp = FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> FilePath
fp)

fromGHCupPath :: GHCupPath -> FilePath
fromGHCupPath :: GHCupPath -> FilePath
fromGHCupPath (GHCupPath FilePath
gp) = FilePath
gp

createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory (GHCupPath FilePath
gp) FilePath
d = FilePath -> GHCupPath
GHCupPath (FilePath -> GHCupPath) -> IO FilePath -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
gp FilePath
d


getGHCupTmpDirs :: IO [GHCupPath]
getGHCupTmpDirs :: IO [GHCupPath]
getGHCupTmpDirs = do
  FilePath
tmpdir <- GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> IO GHCupPath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO GHCupPath
ghcupTMPDir
  [FilePath]
ghcup_dirs <- (IOException -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> Regex -> IO [FilePath]
findFiles
    FilePath
tmpdir
    (CompOption -> ExecOption -> ByteString -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
compExtended
                   ExecOption
execBlank
                   ([s|^ghcup-.*$|] :: ByteString)
    )
  [GHCupPath] -> IO [GHCupPath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FilePath -> GHCupPath) -> [FilePath] -> [GHCupPath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FilePath
p -> FilePath -> GHCupPath
GHCupPath (FilePath
tmpdir FilePath -> ShowS
</> FilePath
p)) ([FilePath] -> [GHCupPath]) -> [FilePath] -> [GHCupPath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (FilePath
"ghcup-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Maybe FilePath -> Bool)
-> (FilePath -> Maybe FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
lastMay ([FilePath] -> Maybe FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitPath) [FilePath]
ghcup_dirs)


    ------------------------------
    --[ 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 GHCupPath
ghcupBaseDir :: IO GHCupPath
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"
      GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".local" FilePath -> ShowS
</> FilePath
"share")
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> 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 GHCupPath
ghcupConfigDir :: IO GHCupPath
ghcupConfigDir
  | Bool
isWindows = IO GHCupPath
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".config")
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> 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 = (GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> IO GHCupPath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO GHCupPath
ghcupBaseDir) IO FilePath -> ShowS -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".local" FilePath -> ShowS
</> FilePath
"bin")
        else (GHCupPath -> FilePath
fromGHCupPath (GHCupPath -> FilePath) -> IO GHCupPath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO GHCupPath
ghcupBaseDir) IO FilePath -> ShowS -> IO FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> ShowS
</> 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 GHCupPath
ghcupCacheDir :: IO GHCupPath
ghcupCacheDir
  | Bool
isWindows = IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".cache")
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> FilePath
"ghcup" FilePath -> ShowS
</> FilePath
"cache"))
        else IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> 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 GHCupPath
ghcupLogsDir :: IO GHCupPath
ghcupLogsDir
  | Bool
isWindows = IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".cache")
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> FilePath
"ghcup" FilePath -> ShowS
</> FilePath
"logs"))
        else IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> FilePath
"logs"))


-- | Defaults to '~/.ghcup/db.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.
ghcupDbDir :: IO GHCupPath
ghcupDbDir :: IO GHCupPath
ghcupDbDir = IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> FilePath
"db"))


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


-- | Defaults to '~/.ghcup/tmp.
--
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
ghcupTMPDir :: IO GHCupPath
ghcupTMPDir :: IO GHCupPath
ghcupTMPDir
  | Bool
isWindows = IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> FilePath
"tmp"))
  | 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FilePath
r  -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
r
            Maybe FilePath
Nothing -> do
              FilePath
home <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
              FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
home FilePath -> ShowS
</> FilePath
".cache")
          GHCupPath -> IO GHCupPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> GHCupPath
GHCupPath (FilePath
bdir FilePath -> ShowS
</> FilePath
"ghcup" FilePath -> ShowS
</> FilePath
"tmp"))
        else IO GHCupPath
ghcupBaseDir IO GHCupPath -> (GHCupPath -> GHCupPath) -> IO GHCupPath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(GHCupPath FilePath
gp) -> FilePath -> GHCupPath
GHCupPath (FilePath
gp FilePath -> ShowS
</> FilePath
"tmp"))


ghcupMsys2Dir :: IO FilePath
ghcupMsys2Dir :: IO FilePath
ghcupMsys2Dir =
  FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHCUP_MSYS2" IO (Maybe FilePath)
-> (Maybe FilePath -> IO FilePath) -> IO FilePath
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
fp -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
fp
    Maybe FilePath
Nothing -> do
      GHCupPath
baseDir <- IO GHCupPath -> IO GHCupPath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GHCupPath
ghcupBaseDir
      FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath -> FilePath
fromGHCupPath GHCupPath
baseDir FilePath -> ShowS
</> FilePath
"msys64")

ghcupMsys2BinDirs :: (MonadFail m, MonadIO m, MonadReader env m, HasDirs env) => m [FilePath]
ghcupMsys2BinDirs :: forall (m :: * -> *) env.
(MonadFail m, MonadIO m, MonadReader env m, HasDirs env) =>
m [FilePath]
ghcupMsys2BinDirs = do
  Dirs{FilePath
GHCupPath
baseDir :: GHCupPath
binDir :: FilePath
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:msys2Dir:Dirs :: Dirs -> FilePath
..} <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
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]
ghcupMsys2BinDirs_ FilePath
msys2Dir

ghcupMsys2BinDirs' :: IO [FilePath]
ghcupMsys2BinDirs' :: IO [FilePath]
ghcupMsys2BinDirs' = do
  FilePath
msys2Dir <- IO FilePath
ghcupMsys2Dir
  FilePath -> IO [FilePath]
ghcupMsys2BinDirs_ FilePath
msys2Dir

ghcupMsys2BinDirs_ :: FilePath -> IO [FilePath]
ghcupMsys2BinDirs_ :: FilePath -> IO [FilePath]
ghcupMsys2BinDirs_ FilePath
msys2Dir' = do
  MSYS2Env
env <- IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHCUP_MSYS2_ENV") IO (Maybe FilePath)
-> (Maybe FilePath -> IO MSYS2Env) -> IO MSYS2Env
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FilePath
env -> IO MSYS2Env
-> (MSYS2Env -> IO MSYS2Env) -> Maybe MSYS2Env -> IO MSYS2Env
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO MSYS2Env
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
parseFailMsg) MSYS2Env -> IO MSYS2Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MSYS2Env -> IO MSYS2Env) -> Maybe MSYS2Env -> IO MSYS2Env
forall a b. (a -> b) -> a -> b
$ forall a. Read a => FilePath -> Maybe a
readMay @MSYS2Env FilePath
env
    Maybe FilePath
Nothing
      | FilePath
"x86_64"  <- FilePath
arch -> MSYS2Env -> IO MSYS2Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MSYS2Env
MINGW64
      | FilePath
"i386"    <- FilePath
arch -> MSYS2Env -> IO MSYS2Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MSYS2Env
MINGW32
      | FilePath
"aarch64" <- FilePath
arch -> MSYS2Env -> IO MSYS2Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MSYS2Env
CLANGARM64
      | Bool
otherwise -> FilePath -> IO MSYS2Env
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No compatible architecture for msys2"
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
msys2Dir' FilePath -> ShowS
</> MSYS2Env -> FilePath
toEnvDir MSYS2Env
env FilePath -> ShowS
</> FilePath
"bin", FilePath
msys2Dir' FilePath -> ShowS
</> MSYS2Env -> FilePath
toEnvDir MSYS2Env
MSYS FilePath -> ShowS
</> FilePath
"bin"]
 where
  -- https://www.msys2.org/docs/environments/
  toEnvDir :: MSYS2Env -> FilePath
  toEnvDir :: MSYS2Env -> FilePath
toEnvDir MSYS2Env
MSYS       = FilePath
"usr"
  toEnvDir MSYS2Env
UCRT64     = FilePath
"ucrt64"
  toEnvDir MSYS2Env
CLANG64    = FilePath
"clang64"
  toEnvDir MSYS2Env
CLANGARM64 = FilePath
"clangarm64"
  toEnvDir MSYS2Env
CLANG32    = FilePath
"clang32"
  toEnvDir MSYS2Env
MINGW64    = FilePath
"mingw64"
  toEnvDir MSYS2Env
MINGW32    = FilePath
"mingw32"

  parseFailMsg :: FilePath
parseFailMsg = FilePath
"Invalid value for GHCUP_MSYS2_ENV. Valid values are: MSYS, UCRT64, CLANG64, CLANGARM64, CLANG32, MINGW64, MINGW32"


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



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

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

getConfigFilePath' :: (MonadReader env m, HasDirs env) => m FilePath
getConfigFilePath' :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m FilePath
getConfigFilePath' = do
  Dirs {FilePath
GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:msys2Dir:Dirs :: Dirs -> FilePath
baseDir :: GHCupPath
binDir :: FilePath
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: FilePath
..} <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ GHCupPath -> FilePath
fromGHCupPath GHCupPath
confDir FilePath -> ShowS
</> FilePath
"config.yaml"


ghcupConfigFile :: (MonadIO m)
                => Excepts '[JSONError] m UserSettings
ghcupConfigFile :: forall (m :: * -> *).
MonadIO m =>
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 a. IO a -> Excepts '[JSONError] m a
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
$ (IOException -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOErrorType
NoSuchThing IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOException -> IOErrorType
ioeGetErrorType IOException
e then Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing else IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ IOException -> IO (Maybe ByteString)
forall a. IOException -> IO a
ioError IOException
e) (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 a. a -> Excepts '[JSONError] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserSettings
defaultUserSettings
      Just ByteString
contents' -> Excepts '[JSONError] m UserSettings
-> Excepts '[JSONError] m UserSettings
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, VEitherLift es es') =>
Excepts es m a -> Excepts es' m a
liftE
        (Excepts '[JSONError] m UserSettings
 -> Excepts '[JSONError] m UserSettings)
-> (ByteString -> Excepts '[JSONError] m UserSettings)
-> ByteString
-> Excepts '[JSONError] m UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (es :: [*]) a.
Monad m =>
VEither es a -> Excepts es m a
veitherToExcepts @_ @'[JSONError]
        (VEither '[JSONError] UserSettings
 -> Excepts '[JSONError] m UserSettings)
-> (ByteString -> VEither '[JSONError] UserSettings)
-> ByteString
-> Excepts '[JSONError] m UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JSONError -> VEither '[JSONError] UserSettings)
-> (UserSettings -> VEither '[JSONError] UserSettings)
-> Either JSONError UserSettings
-> VEither '[JSONError] UserSettings
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (V '[JSONError] -> VEither '[JSONError] UserSettings
forall x (xs :: [*]). V xs -> VEither xs x
VLeft (V '[JSONError] -> VEither '[JSONError] UserSettings)
-> (JSONError -> V '[JSONError])
-> JSONError
-> VEither '[JSONError] UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONError -> V '[JSONError]
forall c (cs :: [*]). (c :< cs) => c -> V cs
V) UserSettings -> VEither '[JSONError] UserSettings
forall x (xs :: [*]). x -> VEither xs x
VRight
        (Either JSONError UserSettings
 -> VEither '[JSONError] UserSettings)
-> (ByteString -> Either JSONError UserSettings)
-> ByteString
-> VEither '[JSONError] UserSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseException -> JSONError)
-> Either ParseException UserSettings
-> Either JSONError UserSettings
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> JSONError
JSONDecodeError (FilePath -> JSONError)
-> (ParseException -> FilePath) -> ParseException -> JSONError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> FilePath
forall e. Exception e => e -> FilePath
displayException)
        (Either ParseException UserSettings
 -> Either JSONError UserSettings)
-> (ByteString -> Either ParseException UserSettings)
-> ByteString
-> Either JSONError 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 GHCupPath
ghcupGHCBaseDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
ghcupGHCBaseDir = do
  Dirs {FilePath
GHCupPath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:msys2Dir:Dirs :: Dirs -> FilePath
baseDir :: GHCupPath
binDir :: FilePath
cacheDir :: GHCupPath
logsDir :: GHCupPath
confDir :: GHCupPath
dbDir :: GHCupPath
recycleDir :: GHCupPath
tmpDir :: GHCupPath
msys2Dir :: FilePath
..}  <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  GHCupPath -> m GHCupPath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
baseDir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` 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 GHCupPath
ghcupGHCDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
GHCTargetVersion -> m GHCupPath
ghcupGHCDir GHCTargetVersion
ver = do
  GHCupPath
ghcbasedir <- m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
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
  GHCupPath -> m GHCupPath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
ghcbasedir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
verdir)


-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir :: forall (m :: * -> *).
MonadThrow m =>
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 :: forall (m :: * -> *). MonadThrow m => 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

-- TODO: inlined from GHCup.Prelude
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither :: forall a (m :: * -> *) b.
(Exception a, MonadThrow m) =>
Either a b -> m b
throwEither Either a b
a = case Either a b
a of
  Left  a
e -> a -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM a
e
  Right b
r -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

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

-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
            => Version
            -> m GHCupPath
ghcupHLSDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadThrow m) =>
Version -> m GHCupPath
ghcupHLSDir Version
ver = do
  GHCupPath
basedir <- m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env) =>
m GHCupPath
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
  GHCupPath -> m GHCupPath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GHCupPath
basedir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
verdir)


mkGhcupTmpDir :: ( MonadReader env m
                 , HasDirs env
                 , MonadUnliftIO m
                 , HasLog env
                 , MonadCatch m
                 , MonadThrow m
                 , MonadMask m
                 , MonadIO m)
              => m GHCupPath
mkGhcupTmpDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
 MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir = FilePath -> GHCupPath
GHCupPath (FilePath -> GHCupPath) -> m FilePath -> m GHCupPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  Dirs { GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
tmpDir } <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
  IO FilePath -> m FilePath
forall a. IO a -> m a
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 (GHCupPath -> FilePath
fromGHCupPath GHCupPath
tmpDir) FilePath
"ghcup"


withGHCupTmpDir :: ( MonadReader env m
                   , HasDirs env
                   , HasLog env
                   , HasSettings env
                   , MonadUnliftIO m
                   , MonadCatch m
                   , MonadResource m
                   , MonadThrow m
                   , MonadMask m
                   , MonadIO m)
                => m GHCupPath
withGHCupTmpDir :: forall env (m :: * -> *).
(MonadReader env m, HasDirs env, HasLog env, HasSettings env,
 MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m,
 MonadMask m, MonadIO m) =>
m GHCupPath
withGHCupTmpDir = do
  Settings{KeepDirs
keepDirs :: KeepDirs
$sel:keepDirs:Settings :: Settings -> KeepDirs
keepDirs} <- m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
  (ReleaseKey, GHCupPath) -> GHCupPath
forall a b. (a, b) -> b
snd ((ReleaseKey, GHCupPath) -> GHCupPath)
-> m (ReleaseKey, GHCupPath) -> m GHCupPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. m a -> IO a) -> IO (ReleaseKey, GHCupPath))
-> m (ReleaseKey, GHCupPath)
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
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, GHCupPath) -> IO (ReleaseKey, GHCupPath)
forall a. m a -> IO a
run
      (m (ReleaseKey, GHCupPath) -> IO (ReleaseKey, GHCupPath))
-> m (ReleaseKey, GHCupPath) -> IO (ReleaseKey, GHCupPath)
forall a b. (a -> b) -> a -> b
$ IO GHCupPath -> (GHCupPath -> IO ()) -> m (ReleaseKey, GHCupPath)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
          (m GHCupPath -> IO GHCupPath
forall a. m a -> IO a
run m GHCupPath
forall env (m :: * -> *).
(MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env,
 MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) =>
m GHCupPath
mkGhcupTmpDir)
          (\GHCupPath
fp -> if -- we don't know whether there was a failure, so can only
                     -- decide for 'Always'
                     | KeepDirs
keepDirs KeepDirs -> KeepDirs -> Bool
forall a. Eq a => a -> a -> Bool
== KeepDirs
Always -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                     | Bool
otherwise -> (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 (GHCupPath -> FilePath
fromGHCupPath GHCupPath
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 ()) -> (GHCupPath -> IO ()) -> GHCupPath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCupPath -> IO ()
removePathForcibly
                        (GHCupPath -> IO ()) -> GHCupPath -> IO ()
forall a b. (a -> b) -> a -> b
$ GHCupPath
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 -> ShowS
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 a. [a] -> 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
cPrefix) FilePath
"..")
          FilePath -> ShowS
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 a. [a] -> 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadMask m, MonadReader env m, HasLog env,
 HasDirs env, HasSettings env) =>
m ()
cleanupTrash = do
  Dirs { GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
recycleDir :: GHCupPath
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 a. IO a -> m a
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 (GHCupPath -> FilePath
fromGHCupPath GHCupPath
recycleDir)
  if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
contents
  then () -> m ()
forall a. a -> m a
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 (GHCupPath -> FilePath
fromGHCupPath GHCupPath
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GHCupPath -> IO ()
removePathForcibly (GHCupPath
recycleDir GHCupPath -> FilePath -> GHCupPath
`appendGHCupPath` FilePath
fp))


-- | List *actual files* in a directory, ignoring empty files and a couple
-- of blacklisted files, such as '.DS_Store' on mac.
listDirectoryFiles :: FilePath -> IO [FilePath]
listDirectoryFiles :: FilePath -> IO [FilePath]
listDirectoryFiles FilePath
fp = do
  FilePath -> IO [FilePath]
listDirectory FilePath
fp IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> ShowS -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
fp FilePath -> ShowS
</>)) IO [FilePath] -> ([FilePath] -> [FilePath]) -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
fp' -> Bool -> Bool
not (FilePath -> Bool
isHidden FilePath
fp') Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
isBlacklisted FilePath
fp'))

-- | List *actual directories* in a directory, ignoring empty directories and a couple
-- of blacklisted files, such as '.DS_Store' on mac.
listDirectoryDirs :: FilePath -> IO [FilePath]
listDirectoryDirs :: FilePath -> IO [FilePath]
listDirectoryDirs FilePath
fp = do
  FilePath -> IO [FilePath]
listDirectory FilePath
fp IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> ShowS -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
fp FilePath -> ShowS
</>)) IO [FilePath] -> ([FilePath] -> [FilePath]) -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FilePath
fp' -> Bool -> Bool
not (FilePath -> Bool
isHidden FilePath
fp') Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
isBlacklisted FilePath
fp'))

isHidden :: FilePath -> Bool
isHidden :: FilePath -> Bool
isHidden FilePath
fp'
  | Bool
isWindows = Bool
False
  | Just (Char
'.', FilePath
_) <- FilePath -> Maybe (Char, FilePath)
forall a. [a] -> Maybe (a, [a])
uncons FilePath
fp' = Bool
True
  | Bool
otherwise = Bool
False

isBlacklisted :: FilePath -> Bool
{- HLINT ignore "Use ==" -}
isBlacklisted :: FilePath -> Bool
isBlacklisted FilePath
fp' = FilePath
fp' FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".DS_Store"]



-- System.Directory re-exports with GHCupPath

removeDirectory :: GHCupPath -> IO ()
removeDirectory :: GHCupPath -> IO ()
removeDirectory (GHCupPath FilePath
fp) = FilePath -> IO ()
SD.removeDirectory FilePath
fp

removeDirectoryRecursive :: GHCupPath -> IO ()
removeDirectoryRecursive :: GHCupPath -> IO ()
removeDirectoryRecursive (GHCupPath FilePath
fp) = FilePath -> IO ()
SD.removeDirectoryRecursive FilePath
fp

removePathForcibly :: GHCupPath -> IO ()
removePathForcibly :: GHCupPath -> IO ()
removePathForcibly (GHCupPath FilePath
fp) = FilePath -> IO ()
SD.removePathForcibly FilePath
fp