{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ViewPatterns      #-}

module GHCup.Utils.File.Common where

import           GHCup.Utils.Prelude

import           Control.Monad.Reader
import           Data.Maybe
import           Data.Text               ( Text )
import           Data.Void
import           GHC.IO.Exception
import           Optics                  hiding ((<|), (|>))
import           System.Directory
import           System.FilePath
import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import           Text.Regex.Posix

import qualified Data.Text                     as T
import qualified Data.ByteString.Lazy          as BL
import qualified Text.Megaparsec               as MP



data ProcessError = NonZeroExit Int FilePath [String]
                  | PTerminated FilePath [String]
                  | PStopped FilePath [String]
                  | NoSuchPid FilePath [String]
                  deriving Int -> ProcessError -> ShowS
[ProcessError] -> ShowS
ProcessError -> String
(Int -> ProcessError -> ShowS)
-> (ProcessError -> String)
-> ([ProcessError] -> ShowS)
-> Show ProcessError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProcessError] -> ShowS
$cshowList :: [ProcessError] -> ShowS
show :: ProcessError -> String
$cshow :: ProcessError -> String
showsPrec :: Int -> ProcessError -> ShowS
$cshowsPrec :: Int -> ProcessError -> ShowS
Show

instance Pretty ProcessError where
  pPrint :: ProcessError -> Doc
pPrint (NonZeroExit Int
e String
exe [String]
args) =
    String -> Doc
text String
"Process" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pPrint String
exe Doc -> Doc -> Doc
<+> String -> Doc
text String
"with arguments" Doc -> Doc -> Doc
<+> [String] -> Doc
forall a. Pretty a => a -> Doc
pPrint [String]
args Doc -> Doc -> Doc
<+> String -> Doc
text String
"failed with exit code" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
  pPrint (PTerminated String
exe [String]
args) =
    String -> Doc
text String
"Process" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pPrint String
exe Doc -> Doc -> Doc
<+> String -> Doc
text String
"with arguments" Doc -> Doc -> Doc
<+> [String] -> Doc
forall a. Pretty a => a -> Doc
pPrint [String]
args Doc -> Doc -> Doc
<+> String -> Doc
text String
"terminated."
  pPrint (PStopped String
exe [String]
args) =
    String -> Doc
text String
"Process" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pPrint String
exe Doc -> Doc -> Doc
<+> String -> Doc
text String
"with arguments" Doc -> Doc -> Doc
<+> [String] -> Doc
forall a. Pretty a => a -> Doc
pPrint [String]
args Doc -> Doc -> Doc
<+> String -> Doc
text String
"stopped."
  pPrint (NoSuchPid String
exe [String]
args) =
    String -> Doc
text String
"Could not find PID for process running " Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pPrint String
exe Doc -> Doc -> Doc
<+> String -> Doc
text String
" with arguments " Doc -> Doc -> Doc
<+> String -> Doc
text ([String] -> String
forall a. Show a => a -> String
show [String]
args) Doc -> Doc -> Doc
<+> String -> Doc
text String
"."

data CapturedProcess = CapturedProcess
  { CapturedProcess -> ExitCode
_exitCode :: ExitCode
  , CapturedProcess -> ByteString
_stdOut   :: BL.ByteString
  , CapturedProcess -> ByteString
_stdErr   :: BL.ByteString
  }
  deriving (CapturedProcess -> CapturedProcess -> Bool
(CapturedProcess -> CapturedProcess -> Bool)
-> (CapturedProcess -> CapturedProcess -> Bool)
-> Eq CapturedProcess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CapturedProcess -> CapturedProcess -> Bool
$c/= :: CapturedProcess -> CapturedProcess -> Bool
== :: CapturedProcess -> CapturedProcess -> Bool
$c== :: CapturedProcess -> CapturedProcess -> Bool
Eq, Int -> CapturedProcess -> ShowS
[CapturedProcess] -> ShowS
CapturedProcess -> String
(Int -> CapturedProcess -> ShowS)
-> (CapturedProcess -> String)
-> ([CapturedProcess] -> ShowS)
-> Show CapturedProcess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CapturedProcess] -> ShowS
$cshowList :: [CapturedProcess] -> ShowS
show :: CapturedProcess -> String
$cshow :: CapturedProcess -> String
showsPrec :: Int -> CapturedProcess -> ShowS
$cshowsPrec :: Int -> CapturedProcess -> ShowS
Show)

makeLenses ''CapturedProcess



-- | Search for a file in the search paths.
--
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
searchPath :: [String] -> String -> IO (Maybe String)
searchPath [String]
paths String
needle = [String] -> IO (Maybe String)
go [String]
paths
 where
  go :: [String] -> IO (Maybe String)
go [] = Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  go (String
x : [String]
xs) =
    [IOErrorType]
-> IO (Maybe String) -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
[IOErrorType] -> m a -> m a -> m a
hideErrorDefM [IOErrorType
InappropriateType, IOErrorType
PermissionDenied, IOErrorType
NoSuchThing] ([String] -> IO (Maybe String)
go [String]
xs)
      (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
          [String]
contents <- String -> IO [String]
listDirectory String
x
          (String -> IO Bool) -> [String] -> IO (Maybe String)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM (String -> String -> IO Bool
isMatch String
x) [String]
contents IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just String
_ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
x String -> ShowS
</> String
needle)
            Maybe String
Nothing -> [String] -> IO (Maybe String)
go [String]
xs
  isMatch :: String -> String -> IO Bool
isMatch String
basedir String
p = do
    if String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
needle
      then String -> IO Bool
isExecutable (String
basedir String -> ShowS
</> String
needle)
      else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  isExecutable :: FilePath -> IO Bool
  isExecutable :: String -> IO Bool
isExecutable String
file = Permissions -> Bool
executable (Permissions -> Bool) -> IO Permissions -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Permissions
getPermissions String
file


-- | Check wether a binary is shadowed by another one that comes before
-- it in PATH. Returns the path to said binary, if any.
isShadowed :: FilePath -> IO (Maybe FilePath)
isShadowed :: String -> IO (Maybe String)
isShadowed String
p = do
  let dir :: String
dir = ShowS
takeDirectory String
p
  let fn :: String
fn = ShowS
takeFileName String
p
  [String]
spaths <- IO [String] -> IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getSearchPath
  if String
dir String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
spaths
  then do
    let shadowPaths :: [String]
shadowPaths = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
dir) [String]
spaths
    [String] -> String -> IO (Maybe String)
searchPath [String]
shadowPaths String
fn
  else Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing


-- | Check whether the binary is in PATH. This returns only `True`
-- if the directory containing the binary is part of PATH.
isInPath :: FilePath -> IO Bool
isInPath :: String -> IO Bool
isInPath String
p = do
  let dir :: String
dir = ShowS
takeDirectory String
p
  let fn :: String
fn = ShowS
takeFileName String
p
  [String]
spaths <- IO [String] -> IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getSearchPath
  if String
dir String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
spaths
  then Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> String -> IO (Maybe String)
searchPath [String
dir] String
fn
  else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False


findFiles :: FilePath -> Regex -> IO [FilePath]
findFiles :: String -> Regex -> IO [String]
findFiles String
path Regex
regex = do
  [String]
contents <- String -> IO [String]
listDirectory String
path
  [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex) [String]
contents

findFilesDeep :: FilePath -> Regex -> IO [FilePath]
findFilesDeep :: String -> Regex -> IO [String]
findFilesDeep String
path Regex
regex = do
  [String]
contents <- String -> IO [String]
getDirectoryContentsRecursive String
path
  [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
match Regex
regex) [String]
contents

findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]
findFiles' :: String -> Parsec Void Text a -> IO [String]
findFiles' String
path Parsec Void Text a
parser = do
  [String]
contents <- String -> IO [String]
listDirectory String
path
  [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
fp -> (ParseErrorBundle Text Void -> Bool)
-> (a -> Bool) -> Either (ParseErrorBundle Text Void) a -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ParseErrorBundle Text Void -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) (Either (ParseErrorBundle Text Void) a -> Bool)
-> Either (ParseErrorBundle Text Void) a -> Bool
forall a b. (a -> b) -> a -> b
$ Parsec Void Text a
-> String -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse Parsec Void Text a
parser String
"" (String -> Text
T.pack String
fp)) [String]
contents


checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
checkFileAlreadyExists :: String -> m Bool
checkFileAlreadyExists String
fp = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fp