{-# 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"