{-# LANGUAGE UndecidableInstances #-}

-- | This module provides the functionality for running shell
-- commands and parsing the result.
--
-- @since 0.1
module Pythia.Internal.ShellApp
  ( -- * SimpleShell
    SimpleShell (..),
    runSimple,

    -- * Trying Multiple IO
    tryIOs,

    -- * Utilities
    runCommand,
  )
where

import Data.ByteString.Lazy qualified as LBS
import Data.Text qualified as T
import Effects.Process.Typed qualified as TP
import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
import Pythia.Control.Exception
  ( CommandException (MkCommandException),
    NoActionsRunException (MkNoActionsRunException),
    NotSupportedException (MkNotSupportedException),
    SomeExceptions (MkSomeExceptions),
  )
import Pythia.Data.Command (Command)
import Pythia.Prelude

-- | Type for running a "simple" shell command given by 'Command'.
-- The 'parser' is used to parse the result.
--
-- @since 0.1
type SimpleShell :: (Type -> Type) -> Type -> Type -> Type
data SimpleShell m err result = MkSimpleShell
  { -- | The shell command to run.
    --
    -- @since 0.1
    forall (m :: Type -> Type) err result.
SimpleShell m err result -> Command
command :: Command,
    -- | Determines if the shell command is supported on this system.
    --
    -- @since 0.1
    forall (m :: Type -> Type) err result.
SimpleShell m err result -> m Bool
isSupported :: m Bool,
    -- | The parser for the result of running the command.
    --
    -- @since 0.1
    forall (m :: Type -> Type) err result.
SimpleShell m err result -> Text -> Either err result
parser :: Text -> Either err result
  }

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Command, b ~ Command) =>
  LabelOptic "command" k (SimpleShell m err result) (SimpleShell m err result) a b
  where
  labelOptic :: Optic
  k NoIx (SimpleShell m err result) (SimpleShell m err result) a b
labelOptic = LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (SimpleShell m err result) (SimpleShell m err result) a b
 -> Lens (SimpleShell m err result) (SimpleShell m err result) a b)
-> LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkSimpleShell Command
_command m Bool
_isSupported Text -> Either err result
_parser) ->
    (Command -> SimpleShell m err result)
-> f Command -> f (SimpleShell m err result)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Command
command' -> Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
forall (m :: Type -> Type) err result.
Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
MkSimpleShell Command
command' m Bool
_isSupported Text -> Either err result
_parser) (a -> f b
f a
Command
_command)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ m Bool, b ~ m Bool) =>
  LabelOptic "isSupported" k (SimpleShell m err result) (SimpleShell m err result) a b
  where
  labelOptic :: Optic
  k NoIx (SimpleShell m err result) (SimpleShell m err result) a b
labelOptic = LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (SimpleShell m err result) (SimpleShell m err result) a b
 -> Lens (SimpleShell m err result) (SimpleShell m err result) a b)
-> LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkSimpleShell Command
_command m Bool
_isSupported Text -> Either err result
_parser) ->
    (m Bool -> SimpleShell m err result)
-> f (m Bool) -> f (SimpleShell m err result)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\m Bool
isSupported' -> Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
forall (m :: Type -> Type) err result.
Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
MkSimpleShell Command
_command m Bool
isSupported' Text -> Either err result
_parser) (a -> f b
f a
m Bool
_isSupported)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ (Text -> Either err result), b ~ (Text -> Either err result)) =>
  LabelOptic "parser" k (SimpleShell m err result) (SimpleShell m err result) a b
  where
  labelOptic :: Optic
  k NoIx (SimpleShell m err result) (SimpleShell m err result) a b
labelOptic = LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL (SimpleShell m err result) (SimpleShell m err result) a b
 -> Lens (SimpleShell m err result) (SimpleShell m err result) a b)
-> LensVL (SimpleShell m err result) (SimpleShell m err result) a b
-> Lens (SimpleShell m err result) (SimpleShell m err result) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkSimpleShell Command
_command m Bool
_isSupported Text -> Either err result
_parser) ->
    ((Text -> Either err result) -> SimpleShell m err result)
-> f (Text -> Either err result) -> f (SimpleShell m err result)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
forall (m :: Type -> Type) err result.
Command
-> m Bool
-> (Text -> Either err result)
-> SimpleShell m err result
MkSimpleShell Command
_command m Bool
_isSupported) (a -> f b
f a
Text -> Either err result
_parser)
  {-# INLINE labelOptic #-}

-- | Runs a simple shell.
--
-- __Throws:__
--
-- * @'NotSupportedException'@: if the command is not supported on this system.
-- * @err@: if running the command throws 'SomeException' or a parse
-- error is encountered.
--
-- @since 0.1
runSimple ::
  forall m err result.
  ( Exception err,
    MonadThrow m,
    MonadTypedProcess m
  ) =>
  SimpleShell m err result ->
  m result
runSimple :: forall (m :: Type -> Type) err result.
(Exception err, MonadThrow m, MonadTypedProcess m) =>
SimpleShell m err result -> m result
runSimple SimpleShell m err result
simple = do
  Bool
supported <- SimpleShell m err result
simple SimpleShell m err result
-> Optic' A_Lens NoIx (SimpleShell m err result) (m Bool) -> m Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (SimpleShell m err result) (m Bool)
#isSupported
  if Bool
supported
    then Command -> m Text
forall (m :: Type -> Type).
(MonadThrow m, MonadTypedProcess m) =>
Command -> m Text
runCommand Command
command m Text -> (Text -> m result) -> m result
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> m result
parseAndThrow
    else NotSupportedException -> m result
forall (m :: Type -> Type) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (NotSupportedException -> m result)
-> NotSupportedException -> m result
forall a b. (a -> b) -> a -> b
$ Text -> NotSupportedException
MkNotSupportedException (Command
command Command -> Optic' An_Iso NoIx Command Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Command Text
#unCommand)
  where
    command :: Command
command = SimpleShell m err result
simple SimpleShell m err result
-> Optic' A_Lens NoIx (SimpleShell m err result) Command -> Command
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (SimpleShell m err result) Command
#command

    parseAndThrow :: Text -> m result
    parseAndThrow :: Text -> m result
parseAndThrow = Either err result -> m result
forall (m :: Type -> Type) e a.
(Exception e, MonadThrow m) =>
Either e a -> m a
throwLeft (Either err result -> m result)
-> (Text -> Either err result) -> Text -> m result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimpleShell m err result
simple SimpleShell m err result
-> Optic'
     A_Lens NoIx (SimpleShell m err result) (Text -> Either err result)
-> Text
-> Either err result
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens NoIx (SimpleShell m err result) (Text -> Either err result)
#parser)
{-# INLINEABLE runSimple #-}

-- | Runs a 'Command' and returns either the text result or error encountered.
-- This is used by 'SimpleShell' to run its command before the result is
-- parsed. This function is exported for convenience.
--
-- __Throws:__
--
-- * 'CommandException': if running the command returns 'ExitFailure' exit
-- code.
--
-- @since 0.1
runCommand :: (MonadThrow m, MonadTypedProcess m) => Command -> m Text
runCommand :: forall (m :: Type -> Type).
(MonadThrow m, MonadTypedProcess m) =>
Command -> m Text
runCommand Command
command = do
  (ExitCode
exitCode, ByteString
out, ByteString
err) <- ProcessConfig () () () -> m (ExitCode, ByteString, ByteString)
forall stdin stdoutIgnored stderrIgnored.
HasCallStack =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
forall (m :: Type -> Type) stdin stdoutIgnored stderrIgnored.
(MonadTypedProcess m, HasCallStack) =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
TP.readProcess (ProcessConfig () () () -> m (ExitCode, ByteString, ByteString))
-> ProcessConfig () () () -> m (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String -> ProcessConfig () () ()
TP.shell (String -> ProcessConfig () () ())
-> String -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cmdStr
  case ExitCode
exitCode of
    ExitCode
ExitSuccess -> Text -> m Text
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8Lenient (ByteString -> ByteString
LBS.toStrict ByteString
out)
    ExitFailure Int
_ ->
      CommandException -> m Text
forall (m :: Type -> Type) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (CommandException -> m Text) -> CommandException -> m Text
forall a b. (a -> b) -> a -> b
$ Command -> Text -> CommandException
MkCommandException Command
command (Text -> CommandException) -> Text -> CommandException
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
err
  where
    cmdStr :: Text
cmdStr = Command
command Command -> Optic' An_Iso NoIx Command Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Command Text
#unCommand
{-# INLINEABLE runCommand #-}

-- Three possible results when running actions:
--
-- 1. None are given/supported, so none are run.
-- 2. We encounter at least one error.
-- 3. We have a success.
--
-- The semigroup takes the first success, as that gives us the semantics we
-- want.
type ActionsResult :: Type -> Type
data ActionsResult r
  = NoRuns
  | Errs (NonEmpty SomeException)
  | Success r

instance Semigroup (ActionsResult r) where
  Success r
x <> :: ActionsResult r -> ActionsResult r -> ActionsResult r
<> ActionsResult r
_ = r -> ActionsResult r
forall r. r -> ActionsResult r
Success r
x
  ActionsResult r
_ <> Success r
x = r -> ActionsResult r
forall r. r -> ActionsResult r
Success r
x
  ActionsResult r
NoRuns <> ActionsResult r
r = ActionsResult r
r
  ActionsResult r
l <> ActionsResult r
NoRuns = ActionsResult r
l
  Errs NonEmpty SomeException
x <> Errs NonEmpty SomeException
y = NonEmpty SomeException -> ActionsResult r
forall r. NonEmpty SomeException -> ActionsResult r
Errs (NonEmpty SomeException -> ActionsResult r)
-> NonEmpty SomeException -> ActionsResult r
forall a b. (a -> b) -> a -> b
$ NonEmpty SomeException
x NonEmpty SomeException
-> NonEmpty SomeException -> NonEmpty SomeException
forall a. Semigroup a => a -> a -> a
<> NonEmpty SomeException
y
  {-# INLINEABLE (<>) #-}

instance Monoid (ActionsResult r) where
  mempty :: ActionsResult r
mempty = ActionsResult r
forall r. ActionsResult r
NoRuns
  {-# INLINEABLE mempty #-}

-- | Generalized 'tryAppActions' to any 'IO'. Has the same semantics
-- (i.e. returns the first success or throws an exception if none
-- succeeds) without checking for "support".
--
-- __Throws:__
--
-- * 'NoActionsRunException': if no actions are run (i.e. the list is empty).
--
-- * 'SomeExceptions': if at least one command is run yet there were no
--       successes.
--
-- @since 0.1
tryIOs ::
  ( MonadCatch m
  ) =>
  [m result] ->
  m result
tryIOs :: forall (m :: Type -> Type) result.
MonadCatch m =>
[m result] -> m result
tryIOs [m result]
actions =
  (m result -> m (ActionsResult result) -> m (ActionsResult result))
-> m (ActionsResult result)
-> [m result]
-> m (ActionsResult result)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m result -> m (ActionsResult result) -> m (ActionsResult result)
forall (m :: Type -> Type) result.
MonadCatch m =>
m result -> m (ActionsResult result) -> m (ActionsResult result)
tryIO (ActionsResult result -> m (ActionsResult result)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ActionsResult result
forall a. Monoid a => a
mempty) [m result]
actions m (ActionsResult result)
-> (ActionsResult result -> m result) -> m result
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Success result
result -> result -> m result
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure result
result
    Errs NonEmpty SomeException
errs -> SomeExceptions -> m result
forall (m :: Type -> Type) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS (SomeExceptions -> m result) -> SomeExceptions -> m result
forall a b. (a -> b) -> a -> b
$ NonEmpty SomeException -> SomeExceptions
MkSomeExceptions NonEmpty SomeException
errs
    ActionsResult result
NoRuns -> NoActionsRunException -> m result
forall (m :: Type -> Type) e a.
(Exception e, HasCallStack, MonadThrow m) =>
e -> m a
throwCS NoActionsRunException
MkNoActionsRunException
{-# INLINEABLE tryIOs #-}

tryIO ::
  ( MonadCatch m
  ) =>
  m result ->
  m (ActionsResult result) ->
  m (ActionsResult result)
tryIO :: forall (m :: Type -> Type) result.
MonadCatch m =>
m result -> m (ActionsResult result) -> m (ActionsResult result)
tryIO m result
action m (ActionsResult result)
acc =
  m result -> m (Either SomeException result)
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny m result
action m (Either SomeException result)
-> (Either SomeException result -> m (ActionsResult result))
-> m (ActionsResult result)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right result
result -> ActionsResult result -> m (ActionsResult result)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ActionsResult result -> m (ActionsResult result))
-> ActionsResult result -> m (ActionsResult result)
forall a b. (a -> b) -> a -> b
$ result -> ActionsResult result
forall r. r -> ActionsResult r
Success result
result
    Left SomeException
ex -> SomeException -> ActionsResult result -> ActionsResult result
forall r. SomeException -> ActionsResult r -> ActionsResult r
appendEx SomeException
ex (ActionsResult result -> ActionsResult result)
-> m (ActionsResult result) -> m (ActionsResult result)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ActionsResult result)
acc
{-# INLINEABLE tryIO #-}

appendEx :: SomeException -> ActionsResult r -> ActionsResult r
appendEx :: forall r. SomeException -> ActionsResult r -> ActionsResult r
appendEx SomeException
e ActionsResult r
x = ActionsResult r
errs ActionsResult r -> ActionsResult r -> ActionsResult r
forall a. Semigroup a => a -> a -> a
<> ActionsResult r
x
  where
    errs :: ActionsResult r
errs = NonEmpty SomeException -> ActionsResult r
forall r. NonEmpty SomeException -> ActionsResult r
Errs (NonEmpty SomeException -> ActionsResult r)
-> NonEmpty SomeException -> ActionsResult r
forall a b. (a -> b) -> a -> b
$ SomeException
e SomeException -> [SomeException] -> NonEmpty SomeException
forall a. a -> [a] -> NonEmpty a
:| []
{-# INLINEABLE appendEx #-}