aboutsummaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2019-01-23 13:15:20 +0100
committertv <tv@krebsco.de>2019-01-23 13:51:10 +0100
commit4fa5cb937c016f8c10bf8f40d017ca3a436db2d3 (patch)
tree1135f4261e3bd2a86c94eff2526befd1c18ae1e9 /src
parentd40815fd56bf1895af89b72b1171675a2e0ae5f7 (diff)
Reaktor.Plugins.System: print exec errors to IRCv0.1.1
Diffstat (limited to 'src')
-rw-r--r--src/Data/ByteString/Char8/Extended.hs6
-rw-r--r--src/Prelude/Extended.hs13
-rw-r--r--src/Reaktor/Internal.hs3
-rw-r--r--src/Reaktor/Plugins/System.hs235
-rw-r--r--src/Reaktor/Plugins/System/Internal.hs107
5 files changed, 189 insertions, 175 deletions
diff --git a/src/Data/ByteString/Char8/Extended.hs b/src/Data/ByteString/Char8/Extended.hs
index 4d46cd2..ca0c44a 100644
--- a/src/Data/ByteString/Char8/Extended.hs
+++ b/src/Data/ByteString/Char8/Extended.hs
@@ -1,11 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.ByteString.Char8.Extended
( module Data.ByteString.Char8
+ , show
) where
import Data.Aeson
import Data.ByteString.Char8
import Data.Text.Encoding (encodeUtf8)
+import Prelude hiding (show)
+import qualified Prelude
instance FromJSON ByteString where
parseJSON (String t) = pure (encodeUtf8 t)
@@ -13,3 +16,6 @@ instance FromJSON ByteString where
instance FromJSONKey ByteString where
fromJSONKey = FromJSONKeyText encodeUtf8
+
+show :: Show a => a -> ByteString
+show = pack . Prelude.show
diff --git a/src/Prelude/Extended.hs b/src/Prelude/Extended.hs
index 5885033..69dc8c8 100644
--- a/src/Prelude/Extended.hs
+++ b/src/Prelude/Extended.hs
@@ -1,8 +1,11 @@
module Prelude.Extended
- ( module Exports
+ ( module Export
) where
-import Control.Monad as Exports (forever,unless,when)
-import Data.Default as Exports (Default,def)
-import Data.Maybe as Exports (fromMaybe,isJust)
-import Prelude as Exports
+import Control.Monad as Export (forever,unless,when)
+import Data.ByteString.Char8.Extended as Export (ByteString)
+import Data.Default as Export (Default,def)
+import Data.HashMap.Lazy as Export (HashMap)
+import Data.Maybe as Export (fromMaybe,isJust,isNothing)
+import Data.Vector as Export (Vector)
+import Prelude as Export
diff --git a/src/Reaktor/Internal.hs b/src/Reaktor/Internal.hs
index 26294b4..74db9c3 100644
--- a/src/Reaktor/Internal.hs
+++ b/src/Reaktor/Internal.hs
@@ -3,11 +3,10 @@
{-# LANGUAGE RecordWildCards #-}
module Reaktor.Internal where
+import Prelude.Extended
import Blessings
import Data.Aeson
-import Data.ByteString (ByteString)
import Network.Socket as Exports (HostName,ServiceName)
-import Prelude.Extended
import qualified Data.ByteString.Char8.Extended as BS
import System.IO
diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs
index 88b8d84..8154423 100644
--- a/src/Reaktor/Plugins/System.hs
+++ b/src/Reaktor/Plugins/System.hs
@@ -5,23 +5,25 @@
{-# LANGUAGE RecordWildCards #-}
module Reaktor.Plugins.System (new) where
---import Prelude.Extended
import Blessings
import Control.Applicative
import Control.Concurrent (forkIO)
-import Control.Exception (finally)
---import Data.Aeson
-import Data.ByteString.Char8.Extended (ByteString)
+import Control.Exception
import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Search as BS
+import qualified Data.HashMap.Lazy as M
+import qualified Data.List as L
+import qualified Data.Vector as V
+import Prelude.Extended
import Reaktor
+import Reaktor.Plugins.System.Internal
import System.Environment (getEnvironment)
+import System.Exit
import System.FilePath.Posix (takeBaseName)
import System.IO (BufferMode(LineBuffering),hSetBuffering)
import System.IO (Handle,hClose,hPutStr,hIsEOF)
-import Reaktor.Plugins.System.Internal -- TODO rename to Reaktor.Plugins.System again
-import System.Process (StdStream(CreatePipe),waitForProcess)
-import System.Process (createProcess,CreateProcess(..),proc)
+import System.Process
import qualified Text.Regex.PCRE.Heavy as RE
import qualified Text.Regex.PCRE.Light as RE
@@ -29,28 +31,27 @@ import qualified Text.Regex.PCRE.Light as RE
new :: Config -> Actions -> IO (Message -> IO ())
new config@Config{..} actions@Actions{..} = do
pure $ \case
- Message (Just prefix) "PRIVMSG" (msgtarget:text:[]) -> do
-
- nick_ <- aGetNick
- let hs = maybe [] id (M.lookup "PRIVMSG" cHooks)
- mapM_ (\h -> run1 config actions nick_ h prefix msgtarget text) hs
+ Message (Just prefix) cmd (msgtarget:text:[]) | elem cmd ["PRIVMSG", "JOIN"] -> do
+ let hooks = maybe [] id (M.lookup cmd cHooks)
+ mapM_ (\h -> run1 config actions h prefix msgtarget text) hooks
Message (Just prefix) "JOIN" (channel:[]) -> do
- nick_ <- aGetNick
- let hs = maybe [] id (M.lookup "JOIN" cHooks)
- mapM_ (\h -> run1 config actions nick_ h prefix channel "") hs
+ let hooks = maybe [] id (M.lookup "JOIN" cHooks)
+ mapM_ (\h -> run1 config actions h prefix channel "") hooks
_ -> pure ()
-run1 :: Config -> Actions -> ByteString -> SystemParams -> ByteString -> ByteString -> ByteString -> IO ()
-run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text = do
+run1 :: Config -> Actions -> Hook -> ByteString -> ByteString -> ByteString -> IO ()
+run1 Config{..} Actions{..} Hook{..} prefix msgtarget text = do
+ nick <- aGetNick
+
let
isActivated =
- case activate params of
+ case hActivate of
Always -> Just ""
Match ->
- case pattern params of
+ case hPattern of
Nothing -> Nothing
Just pat ->
let
@@ -62,8 +63,8 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
else Just ""
Query ->
if
- | BS.isPrefixOf (nick_ <> ":") text ->
- Just (nick_ <> ":")
+ | BS.isPrefixOf (nick <> ":") text ->
+ Just (nick <> ":")
| BS.isPrefixOf "*:" text ->
Just "*:"
| isQuery ->
@@ -72,17 +73,16 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
Nothing
audience = if isQuery then from else msgtarget
+ from = BS.takeWhile (/='!') prefix
-- TODO check if msgtarget is one of our channels?
-- what if our nick has changed?
- isQuery = msgtarget == nick_
-
- from = BS.takeWhile (/='!') prefix
- --maybe prefix (flip BS.take prefix) $ BS.findIndex (=='!') prefix
+ isQuery = msgtarget == nick
case isActivated of
Just trigger -> do
- let cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
+ let
+ cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
resultPrefix = if isQuery then [] else [from <> ":"]
parseCommandLine' pat s =
@@ -91,106 +91,109 @@ run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text =
result = RE.scan patternRE s
patternRE = RE.compile pat []
- parse' =
- case pattern params of
- Nothing -> [] -- TODO everything
- Just pat -> parseCommandLine' pat cmdline
-
- headMaybe x = if null x then Nothing else Just (head x)
-
- -- TODO rename "command" to something like "commandSpec"
- command' = case command params of
- Capture i ->
- case headMaybe (drop (fromIntegral i - 1) parse') of
- Nothing -> Nothing
- Just k -> M.lookup k (commands params)
-
- CaptureOr c -> Just c
-
- cmdName = case command params of
- Capture i ->
- case headMaybe (drop (fromIntegral i - 1) parse') of
- Nothing -> "<CMDERP>"
- Just k -> k
-
- CaptureOr c -> BS.pack (takeBaseName $ commandPath c)
-
- args' =
- map BS.unpack $
- map (maybe "" id) $
- reverse $
- dropWhile (==Nothing) $
- reverse $
- map f (arguments params)
- where
- f arg = case arg of
- Capture i ->
- case headMaybe (drop (fromIntegral i - 1) parse') of
- Nothing -> Nothing
- Just k -> Just k
-
- CaptureOr x -> Just x
-
- case command' of
- Just c -> do
- -- aSend <- gets s_sendMsg
- -- putLog_ <- gets s_putLog
- let onErrLine s =
- aLog $ SGR [31,1] $
- Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s)
-
- onOutLine s =
- aSend (privmsg audience [s])
-
- extraEnv = [("_prefix", BS.unpack prefix),
- ("_from", BS.unpack from)]
-
- fork config actions c args' (Just extraEnv) "" onOutLine onErrLine
+ captures =
+ V.fromList $
+ case hPattern of
+ Nothing -> [] -- TODO everything?
+ Just pat -> parseCommandLine' pat cmdline
+
+ capture i = captures V.!? (i - 1)
+
+ name =
+ case hCommand of
+ Capture i -> fromMaybe "<unnamed>" (capture i)
+ CaptureOr Command{..} -> BS.pack $ takeBaseName $ commandPath
+
+ command =
+ case hCommand of
+ Capture i -> (`M.lookup` hCommands) =<< capture i
+ CaptureOr c -> Just c
+
+ args =
+ map (maybe "" BS.unpack)
+ $ L.dropWhileEnd isNothing
+ -- $ map getArgument hArguments
+ $ flip map hArguments
+ $ \case
+ Capture i -> capture i
+ CaptureOr s -> Just s
+
+ case command of
+ Just Command{..} -> do
+ baseEnv <- getEnvironment
+
+ let
+ onExit code = do
+ let s = BS.show code
+ (sig, col) =
+ if code == ExitSuccess
+ then (SGR [38,5,235] "* ", SGR [38,5,107])
+ else (SGR [38,5,235] "! ", SGR [31,1])
+ aLog $ sig <> col (Plain $ name <> ": " <> s)
+
+ onExcept :: SomeException -> IO ()
+ onExcept e = do
+ let s0 = BS.show e
+ s = BL.toStrict $ BS.replace (BS.pack commandPath) name s0
+ aLog $ SGR [38,5,235] "! "
+ <> SGR [31,1] (Plain $ name <> ": " <> s0)
+ aSend (privmsg audience (resultPrefix <> [s]))
+
+ -- TODO use differenct colors
+ onErrLine s = aSend (privmsg audience [s])
+ onOutLine s = aSend (privmsg audience [s])
+
+ extraEnv =
+ [ ("_prefix", BS.unpack prefix)
+ , ("_from", BS.unpack from)
+ ]
+
+ env =
+ M.toList $ mconcat
+ [ M.fromList extraEnv
+ , maybe mempty id commandEnv
+ , M.fromList baseEnv
+ ]
+
+ cwd = commandWorkDir <|> hWorkDir <|> cWorkDir
+
+ fork commandPath args cwd (Just env) "" onOutLine onErrLine onExit
+ `catch` onExcept
Nothing -> do
- aSend (privmsg audience (resultPrefix <> [cmdName <> ": command not found"]))
+ let s = name <> ": command not found"
+ aSend (privmsg audience (resultPrefix <> [s]))
Nothing -> return ()
-fork :: Config
- -> Actions
- -> SystemCommand
+fork :: FilePath
-> [String]
+ -> Maybe FilePath
-> Maybe [(String, String)]
-> String
-> (ByteString -> IO ())
-> (ByteString -> IO ())
+ -> (ExitCode -> IO ())
-> IO ()
-fork Config{..} Actions{..} cmd args extraEnv input onOutLine onErrLine = do
-
- baseEnv <- getEnvironment
-
- let procEnv = M.toList $ mconcat [
- maybe mempty M.fromList extraEnv,
- maybe mempty id (commandEnv cmd),
- M.fromList baseEnv
- ]
-
- (inh, outh, errh) <- do
- (Just inh, Just outh, Just errh, ph) <-
- createProcess (proc (commandPath cmd) args) {
- cwd = commandWorkDir cmd <|> cDefaultWorkDir,
- env = Just procEnv,
- std_in = CreatePipe,
- std_out = CreatePipe,
- std_err = CreatePipe,
- close_fds = True,
- create_group = True,
- new_session = True
- }
- _ <- forkIO $ waitForProcess ph >> return ()
- return (inh, outh, errh)
-
- mapM_ forkIO [
- hPutStr inh input `finally` hClose inh,
- hWithLines outh onOutLine,
- hWithLines errh onErrLine
- ]
+fork path args cwd env input onOutLine onErrLine onExit = do
+ let
+ p = (proc path args)
+ { cwd = cwd
+ , env = env
+ , std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ , close_fds = True
+ , create_group = True
+ , new_session = True
+ }
+ withCreateProcess p $ \(Just inh) (Just outh) (Just errh) ph -> do
+ mapM_ forkIO [
+ hPutStr inh input `finally` hClose inh,
+ hWithLines outh onOutLine,
+ hWithLines errh onErrLine
+ ]
+ waitForProcess ph >>= onExit
hWithLines :: Handle -> (ByteString -> IO ()) -> IO ()
diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs
index 2ed923d..ac707ae 100644
--- a/src/Reaktor/Plugins/System/Internal.hs
+++ b/src/Reaktor/Plugins/System/Internal.hs
@@ -1,15 +1,15 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Reaktor.Plugins.System.Internal where
import Prelude.Extended
import Data.Aeson
-import qualified Data.ByteString.Char8.Extended as BS
-import qualified Data.Map as M
import Reaktor ()
+
-- TODO this needs better names :)
-data CaptureOr a = Capture Integer | CaptureOr a
+data CaptureOr a = Capture Int | CaptureOr a
deriving Show -- TODO killme
instance FromJSON a => FromJSON (CaptureOr a) where
@@ -20,60 +20,63 @@ instance FromJSON a => FromJSON (CaptureOr a) where
data Activate = Always | Match | Query
instance FromJSON Activate where
- parseJSON (String "always") = pure Always
- parseJSON (String "match") = pure Match
- parseJSON (String "query") = pure Query
- parseJSON _ = undefined
+ parseJSON = \case
+ String "always" -> pure Always
+ String "match" -> pure Match
+ String "query" -> pure Query
+ _ -> undefined
-data Config = Config {
- cDefaultWorkDir :: Maybe FilePath,
- -- TODO IrcCommand as key for map
- cHooks :: M.Map BS.ByteString [SystemParams]
-}
+data Config = Config
+ { cWorkDir :: Maybe FilePath
+ , cHooks :: HashMap ByteString [Hook]
+ }
instance Default Config where
def = Config Nothing mempty
instance FromJSON Config where
- parseJSON (Object v) =
- Config
- <$> v .:? "workdir"
- <*> v .:? "hooks" .!= M.empty
- parseJSON _ = pure undefined
-
-data SystemParams = SystemParams {
- activate :: Activate,
- pattern :: Maybe BS.ByteString, -- TODO RE
- command :: CaptureOr SystemCommand,
- arguments :: [CaptureOr BS.ByteString],
- workDir :: Maybe FilePath,
- commands :: M.Map BS.ByteString SystemCommand
-}
-
-instance FromJSON SystemParams where
- parseJSON (Object v) =
- SystemParams
- <$> v .:? "activate" .!= Query
- <*> v .:? "pattern"
- <*> v .: "command"
- <*> v .:? "arguments" .!= []
- <*> v .:? "workdir"
- <*> v .:? "commands" .!= M.empty
- parseJSON _ = pure undefined
-
-
-data SystemCommand = SystemCommand {
- commandPath :: FilePath,
- commandWorkDir :: Maybe FilePath,
- commandEnv :: Maybe (M.Map String String)
- }
- deriving Show -- TODO killme
+ parseJSON = \case
+ Object v ->
+ Config
+ <$> v .:? "workdir"
+ <*> v .:? "hooks" .!= mempty
+ _ -> undefined
+
+data Hook = Hook
+ { hActivate :: Activate
+ , hPattern :: Maybe ByteString
+ , hCommand :: CaptureOr Command
+ , hArguments :: [CaptureOr ByteString]
+ , hWorkDir :: Maybe FilePath
+ , hCommands :: HashMap ByteString Command
+ }
+
+instance FromJSON Hook where
+ parseJSON = \case
+ Object v ->
+ Hook
+ <$> v .:? "activate" .!= Query
+ <*> v .:? "pattern"
+ <*> v .: "command"
+ <*> v .:? "arguments" .!= []
+ <*> v .:? "workdir"
+ <*> v .:? "commands" .!= mempty
+ _ -> undefined
+
+
+data Command = Command
+ { commandPath :: FilePath
+ , commandWorkDir :: Maybe FilePath
+ , commandEnv :: Maybe (HashMap String String)
+ }
+ deriving Show
-instance FromJSON SystemCommand where
- parseJSON (Object v) =
- SystemCommand
- <$> v .: "filename"
- <*> v .:? "workdir"
- <*> v .:? "env"
- parseJSON _ = pure undefined
+instance FromJSON Command where
+ parseJSON = \case
+ Object v ->
+ Command
+ <$> v .: "filename"
+ <*> v .:? "workdir"
+ <*> v .:? "env"
+ _ -> undefined