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

{-# 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
  , useXDG
  , cleanupTrash

  , GHCupPath
  , appendGHCupPath
  , fromGHCupPath
  , createTempGHCupDirectory
  , getGHCupTmpDirs

  , removeDirectory
  , removeDirectoryRecursive
  , removePathForcibly

  -- 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
import           Safe
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 (Show, Eq, Ord)

instance NFData GHCupPath where
  rnf (GHCupPath fp) = rnf fp

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

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

createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d


getGHCupTmpDirs :: IO [GHCupPath]
getGHCupTmpDirs = do
  tmpdir <- fromGHCupPath <$> ghcupTMPDir
  ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
    tmpdir
    (makeRegexOpts compExtended
                   execBlank
                   ([s|^ghcup-.*$|] :: ByteString)
    )
  pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) 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
  | isWindows = do
      bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
      pure (GHCupPath (bdir </> "ghcup"))
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".local" </> "share")
          pure (GHCupPath (bdir </> "ghcup"))
        else do
          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
            Just r  -> pure r
            Nothing -> liftIO getHomeDirectory
          pure (GHCupPath (bdir </> ".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
  | isWindows = ghcupBaseDir
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".config")
          pure (GHCupPath (bdir </> "ghcup"))
        else do
          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
            Just r  -> pure r
            Nothing -> liftIO getHomeDirectory
          pure (GHCupPath (bdir </> ".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
  | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin")
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          lookupEnv "XDG_BIN_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".local" </> "bin")
        else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "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
  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache"))
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".cache")
          pure (GHCupPath (bdir </> "ghcup"))
        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "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
  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs"))
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".cache")
          pure (GHCupPath (bdir </> "ghcup" </> "logs"))
        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "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
  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".cache")
          pure (GHCupPath (bdir </> "ghcup" </> "db"))
        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))


-- | '~/.ghcup/trash'.
-- Mainly used on windows to improve file removal operations
ghcupRecycleDir :: IO GHCupPath
ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "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
  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
            Just r  -> pure r
            Nothing -> do
              home <- liftIO getHomeDirectory
              pure (home </> ".cache")
          pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))


getAllDirs :: IO Dirs
getAllDirs = do
  baseDir    <- ghcupBaseDir
  binDir     <- ghcupBinDir
  cacheDir   <- ghcupCacheDir
  logsDir    <- ghcupLogsDir
  confDir    <- ghcupConfigDir
  recycleDir <- ghcupRecycleDir
  tmpDir     <- ghcupTMPDir
  dbDir      <- ghcupDbDir
  pure Dirs { .. }



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

getConfigFilePath :: (MonadIO m) => m FilePath
getConfigFilePath = do
  confDir <- liftIO ghcupConfigDir
  pure $ fromGHCupPath confDir </> "config.yaml"

ghcupConfigFile :: (MonadIO m)
                => Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
  filepath <- getConfigFilePath
  contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
  case contents of
      Nothing -> pure defaultUserSettings
      Just contents' -> liftE
        . veitherToExcepts @_ @'[JSONError]
        . either (VLeft . V) VRight
        . first (JSONDecodeError . displayException)
        . Y.decodeEither'
        $ contents'


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


-- | ~/.ghcup/ghc by default.
ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
ghcupGHCBaseDir = do
  Dirs {..}  <- getDirs
  pure (baseDir `appendGHCupPath` "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 ver = do
  ghcbasedir <- ghcupGHCBaseDir
  let verdir = T.unpack $ tVerToText ver
  pure (ghcbasedir `appendGHCupPath` verdir)


-- | See 'ghcupToolParser'.
parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
  throwEither $ MP.parse ghcTargetVerP "" fp

parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
parseGHCupHLSDir (T.pack -> fp) =
  throwEither $ MP.parse version' "" fp

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

-- | ~/.ghcup/hls by default, for new-style installs.
ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
ghcupHLSBaseDir = do
  Dirs {..}  <- getDirs
  pure (baseDir `appendGHCupPath` "hls")

-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
            => Version
            -> m GHCupPath
ghcupHLSDir ver = do
  basedir <- ghcupHLSBaseDir
  let verdir = T.unpack $ prettyVer ver
  pure (basedir `appendGHCupPath` verdir)


mkGhcupTmpDir :: ( MonadReader env m
                 , HasDirs env
                 , MonadUnliftIO m
                 , HasLog env
                 , MonadCatch m
                 , MonadThrow m
                 , MonadMask m
                 , MonadIO m)
              => m GHCupPath
mkGhcupTmpDir = GHCupPath <$> do
  Dirs { tmpDir } <- getDirs
  liftIO $ createTempDirectory (fromGHCupPath tmpDir) "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 = do
  Settings{keepDirs} <- getSettings
  snd <$> withRunInIO (\run ->
    run
      $ allocate
          (run mkGhcupTmpDir)
          (\fp -> if -- we don't know whether there was a failure, so can only
                     -- decide for 'Always'
                     | keepDirs == Always -> pure ()
                     | otherwise -> handleIO (\e -> run
                        $ logDebug ("Resource cleanup failed for "
                                   <> T.pack (fromGHCupPath fp)
                                   <> ", error was: "
                                   <> T.pack (displayException e)))
                        . removePathForcibly
                        $ fp))




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


useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "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 p1 p2
  | isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
  | otherwise =
    let d1      = splitDirectories p1
        d2      = splitDirectories p2
        common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
        cPrefix = drop (length common) d1
    in  joinPath (replicate (length cPrefix) "..")
          <> joinPath ([pathSeparator] : drop (length common) d2)


cleanupTrash :: ( MonadIO m
                , MonadMask m
                , MonadReader env m
                , HasLog env
                , HasDirs env
                , HasSettings env
                )
             => m ()
cleanupTrash = do
  Dirs { recycleDir } <- getDirs
  contents <- liftIO $ listDirectory (fromGHCupPath recycleDir)
  if null contents
  then pure ()
  else do
    logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir))
    forM_ contents (\fp -> handleIO (\e ->
        logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
      ) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp))



-- System.Directory re-exports with GHCupPath

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

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

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