diff options
Diffstat (limited to 'src/Reaktor')
| -rw-r--r-- | src/Reaktor/Internal.hs | 3 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System.hs | 235 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System/Internal.hs | 107 |
3 files changed, 175 insertions, 170 deletions
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 |