{-# LANGUAGE RankNTypes #-}
module Matterhorn.Scripts
  ( findAndRunScript
  , listScripts
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Control.Concurrent ( takeMVar, newEmptyMVar )
import qualified Control.Concurrent.STM as STM
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Lens.Micro.Platform ( Lens' )
import           System.Exit ( ExitCode(..) )

import           Matterhorn.FilePaths ( Script(..), getAllScripts, locateScriptPath )
import           Matterhorn.State.Common
import           Matterhorn.State.Messages ( sendMessage )
import           Matterhorn.Types


findAndRunScript :: Lens' ChatState (EditState Name) -> Text -> Text -> MH ()
findAndRunScript :: Lens' ChatState (EditState Name) -> Text -> Text -> MH ()
findAndRunScript Lens' ChatState (EditState Name)
which Text
scriptName Text
input = do
    Script
fpMb <- IO Script -> MH Script
forall a. IO a -> MH a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Script -> MH Script) -> IO Script -> MH Script
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Script
locateScriptPath (Text -> FilePath
T.unpack Text
scriptName)
    TChan ProgramOutput
outputChan <- Getting (TChan ProgramOutput) ChatState (TChan ProgramOutput)
-> MH (TChan ProgramOutput)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const (TChan ProgramOutput) ChatResources)
-> ChatState -> Const (TChan ProgramOutput) ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const (TChan ProgramOutput) ChatResources)
 -> ChatState -> Const (TChan ProgramOutput) ChatState)
-> ((TChan ProgramOutput
     -> Const (TChan ProgramOutput) (TChan ProgramOutput))
    -> ChatResources -> Const (TChan ProgramOutput) ChatResources)
-> Getting (TChan ProgramOutput) ChatState (TChan ProgramOutput)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TChan ProgramOutput
 -> Const (TChan ProgramOutput) (TChan ProgramOutput))
-> ChatResources -> Const (TChan ProgramOutput) ChatResources
Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog)
    case Script
fpMb of
      ScriptPath FilePath
scriptPath -> do
        AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ Lens' ChatState (EditState Name)
-> TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))
runScript (EditState Name -> f (EditState Name)) -> ChatState -> f ChatState
Lens' ChatState (EditState Name)
which TChan ProgramOutput
outputChan FilePath
scriptPath Text
input
      NonexecScriptPath FilePath
scriptPath -> do
        let msg :: Text
msg = (Text
"The script `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
scriptPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` cannot be " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
"executed. Try running\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
"$ chmod u+x " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
scriptPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
"to correct this error. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scriptHelpAddendum)
        MHError -> MH ()
mhError (MHError -> MH ()) -> MHError -> MH ()
forall a b. (a -> b) -> a -> b
$ Text -> MHError
GenericError Text
msg
      Script
ScriptNotFound -> do
        MHError -> MH ()
mhError (MHError -> MH ()) -> MHError -> MH ()
forall a b. (a -> b) -> a -> b
$ Text -> MHError
NoSuchScript Text
scriptName

runScript :: Lens' ChatState (EditState Name)
          -> STM.TChan ProgramOutput
          -> FilePath
          -> Text
          -> IO (Maybe (MH ()))
runScript :: Lens' ChatState (EditState Name)
-> TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))
runScript Lens' ChatState (EditState Name)
which TChan ProgramOutput
outputChan FilePath
fp Text
text = do
  MVar ProgramOutput
outputVar <- IO (MVar ProgramOutput)
forall a. IO (MVar a)
newEmptyMVar
  TChan ProgramOutput
-> FilePath
-> [FilePath]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan FilePath
fp [] (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
text) (MVar ProgramOutput -> Maybe (MVar ProgramOutput)
forall a. a -> Maybe a
Just MVar ProgramOutput
outputVar)
  ProgramOutput
po <- MVar ProgramOutput -> IO ProgramOutput
forall a. MVar a -> IO a
takeMVar MVar ProgramOutput
outputVar
  Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ case ProgramOutput -> ExitCode
programExitCode ProgramOutput
po of
    ExitCode
ExitSuccess -> do
        case FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ ProgramOutput -> FilePath
programStderr ProgramOutput
po of
            Bool
True -> MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
                EditMode
mode <- Getting EditMode ChatState EditMode -> MH EditMode
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((EditState Name -> Const EditMode (EditState Name))
-> ChatState -> Const EditMode ChatState
Lens' ChatState (EditState Name)
which((EditState Name -> Const EditMode (EditState Name))
 -> ChatState -> Const EditMode ChatState)
-> ((EditMode -> Const EditMode EditMode)
    -> EditState Name -> Const EditMode (EditState Name))
-> Getting EditMode ChatState EditMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EditMode -> Const EditMode EditMode)
-> EditState Name -> Const EditMode (EditState Name)
forall n (f :: * -> *).
Functor f =>
(EditMode -> f EditMode) -> EditState n -> f (EditState n)
esEditMode)
                ChannelId
cId <- Getting ChannelId ChatState ChannelId -> MH ChannelId
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((EditState Name -> Const ChannelId (EditState Name))
-> ChatState -> Const ChannelId ChatState
Lens' ChatState (EditState Name)
which((EditState Name -> Const ChannelId (EditState Name))
 -> ChatState -> Const ChannelId ChatState)
-> ((ChannelId -> Const ChannelId ChannelId)
    -> EditState Name -> Const ChannelId (EditState Name))
-> Getting ChannelId ChatState ChannelId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ChannelId -> Const ChannelId ChannelId)
-> EditState Name -> Const ChannelId (EditState Name)
forall n (f :: * -> *).
Functor f =>
(ChannelId -> f ChannelId) -> EditState n -> f (EditState n)
esChannelId)
                ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()
sendMessage ChannelId
cId EditMode
mode (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ProgramOutput -> FilePath
programStdout ProgramOutput
po) []
            Bool
False -> Maybe (MH ())
forall a. Maybe a
Nothing
    ExitFailure Int
_ -> Maybe (MH ())
forall a. Maybe a
Nothing

listScripts :: MH ()
listScripts :: MH ()
listScripts = do
  ([FilePath]
execs, [FilePath]
nonexecs) <- IO ([FilePath], [FilePath]) -> MH ([FilePath], [FilePath])
forall a. IO a -> MH a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ([FilePath], [FilePath])
getAllScripts
  let scripts :: Text
scripts = (Text
"Available scripts are:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                 [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
"  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                         | FilePath
cmd <- [FilePath]
execs
                         ])
  Text -> MH ()
postInfoMessage Text
scripts
  case [FilePath]
nonexecs of
    [] -> () -> MH ()
forall a. a -> MH a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [FilePath]
_  -> do
      let errMsg :: Text
errMsg = (Text
"Some non-executable script files are also " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"present. If you want to run these as scripts " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"in Matterhorn, mark them executable with \n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"$ chmod u+x [script path]\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
"  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                            | FilePath
cmd <- [FilePath]
nonexecs
                            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scriptHelpAddendum)
      MHError -> MH ()
mhError (MHError -> MH ()) -> MHError -> MH ()
forall a b. (a -> b) -> a -> b
$ Text -> MHError
GenericError Text
errMsg

scriptHelpAddendum :: Text
scriptHelpAddendum :: Text
scriptHelpAddendum =
  Text
"For more help with scripts, run the command\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
  Text
"```\n/help scripts\n```\n"