diff options
| -rw-r--r-- | src/Reaktor.hs | 236 | ||||
| -rw-r--r-- | src/Reaktor/Config.hs | 76 | ||||
| -rw-r--r-- | src/Reaktor/Message.hs | 14 | ||||
| -rw-r--r-- | src/Reaktor/Parser.hs | 45 | ||||
| -rw-r--r-- | src/Reaktor/Plugins.hs | 28 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Mention.hs | 27 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/NickServ.hs | 92 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Ping.hs | 15 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Register.hs | 65 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System.hs | 213 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System/Types.hs | 75 | ||||
| -rw-r--r-- | src/Reaktor/Types.hs | 68 | ||||
| -rw-r--r-- | src/Reaktor/Utils.hs | 37 | ||||
| -rw-r--r-- | src/main.hs | 14 |
14 files changed, 1005 insertions, 0 deletions
diff --git a/src/Reaktor.hs b/src/Reaktor.hs new file mode 100644 index 0000000..110485f --- /dev/null +++ b/src/Reaktor.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Reaktor (run) where + +import Blessings (Blessings(Append,Empty,Plain,SGR),pp) +import Control.Arrow +import Control.Concurrent (forkIO,killThread,threadDelay) +import Control.Concurrent (newEmptyMVar,putMVar,takeMVar) +import Control.Exception (finally) +import Control.Monad (foldM,forever,unless) +import Control.Monad.Trans.State.Lazy +import Data.Aeson +import Data.Attoparsec.ByteString.Char8 (IResult(Done,Fail,Partial)) +import Data.Attoparsec.ByteString.Char8 (feed,parse) +import qualified Data.ByteString.Char8 as BS +import Data.Foldable (toList) +import qualified Data.Text as T +import Data.Time.Clock.System +import Data.Time.Format +import qualified Network.Simple.TCP as TCP +import qualified Network.Simple.TCP.TLS as TLS +import Reaktor.Config +import Reaktor.Parser (message) +import qualified Reaktor.Plugins +import Reaktor.Types +import System.IO (BufferMode(LineBuffering),hSetBuffering) +import System.IO (Handle) +import System.IO (hIsTerminalDevice) +import System.IO (hPutStr,hPutStrLn,stderr) +import System.Posix.Signals + + +run :: Config -> IO () +run cfg0 = do + + let logh = stderr + + let cfg1 = addPlugin "ping" (Reaktor.Plugins.get "ping" Null) cfg0 + + cfg <- initPlugins cfg1 + + let tlsPlugins = + T.unpack $ + T.intercalate ", " $ + map pi_name $ + filter (requireTLS . either undefined id . pi_plugin) + (pluginInstances cfg) + + unless (useTLS cfg || null tlsPlugins) $ do + error $ "Not using TLS, but following plugins require it: " <> tlsPlugins + + -- TODO reset when done? + hSetBuffering logh LineBuffering + logToTTY <- hIsTerminalDevice logh + let logFilter = if logToTTY then id else stripSGR + + connect cfg $ \send_ recv_ -> do + (putLog, takeLog) <- newRelay + (putMsg, takeMsg) <- newRelay + (shutdown, awaitShutdown) <- newSemaphore + + mapM_ (\(s, f) -> installHandler s (Catch f) Nothing) [ + (sigINT, shutdown) + ] + + let prefixTimestamp s = do + t <- SGR [38,5,239] . Plain . BS.pack <$> getTimestamp + return (t <> " " <> s) + + takeLog' = + if logTime cfg + then takeLog >>= prefixTimestamp + else takeLog + + threadIds <- mapM (\f -> forkIO $ f `finally` shutdown) [ + driver cfg putLog putMsg recv_, + logger logFilter takeLog' logh, + pinger putLog putMsg, + sender takeMsg send_ + ] + + awaitShutdown + mapM_ killThread threadIds + hPutStrLn logh "" + where + + pinger :: (Blessings BS.ByteString -> IO ()) -> (Message -> IO ()) -> IO () + pinger putLog putMsg = forever $ do + threadDelay time + sendIO putLog putMsg (Message Nothing "PING" ["heartbeat"]) + where + time = 300 * 1000000 + + sender :: IO Message -> (BS.ByteString -> IO ()) -> IO () + sender takeMsg send_ = + forever $ takeMsg >>= send_ . formatMessage + + logger :: (Blessings BS.ByteString -> Blessings BS.ByteString) + -> IO (Blessings BS.ByteString) + -> Handle + -> IO () + logger f takeLog h = forever $ do + s <- takeLog + let s' = if lastChar s == '\n' then s else s <> Plain "\n" + hPutStr h $ pp $ fmap BS.unpack (f s') + where + lastChar :: Blessings BS.ByteString -> Char + lastChar = BS.last . last . toList + + stripSGR :: Blessings a -> Blessings a + stripSGR = \case + Append t1 t2 -> Append (stripSGR t1) (stripSGR t2) + SGR _ t -> stripSGR t + Plain x -> Plain x + Empty -> Empty + + +connect :: Config + -> ((BS.ByteString -> IO ()) -> IO (Maybe BS.ByteString) -> IO ()) + -> IO () +connect cfg action = do + if useTLS cfg then do + s <- TLS.getDefaultClientSettings (hostname cfg, BS.pack (port cfg)) + TLS.connect s (hostname cfg) (port cfg) $ \(ctx, _sockAddr) -> do + let send = TLS.send ctx + recv = TLS.recv ctx + action send recv + else do + TCP.connect (hostname cfg) (port cfg) $ \(sock, _sockAddr) -> do + let send = TCP.send sock + recv = TCP.recv sock 512 + action send recv + +driver :: Config + -> (Blessings BS.ByteString -> IO ()) + -> (Message -> IO ()) + -> IO (Maybe BS.ByteString) + -> IO () + +driver cfg putLog putMsg recv_ = do + cfg' <- handleMessage cfg putMsg putLog (Message Nothing "<start>" []) + drive cfg' putMsg putLog recv_ "" + +drive :: Config + -> (Message -> IO ()) + -> (Blessings BS.ByteString -> IO ()) + -> IO (Maybe BS.ByteString) + -> BS.ByteString + -> IO () +drive cfg putMsg putLog recv_ "" = + recv_ >>= \case + Nothing -> putLog $ SGR [34,1] (Plain "# EOL") + Just msg -> drive cfg putMsg putLog recv_ msg + +drive cfg putMsg putLog recv_ buf = + go (parse message buf) + where + go :: IResult BS.ByteString Message -> IO () + go = \case + Done rest msg -> do + -- TODO log message only if h hasn't disabled logging for it + let s = formatMessage msg + putLog $ SGR [38,5,235] "< " <> SGR [38,5,244] (Plain s) + cfg' <- handleMessage cfg putMsg putLog msg + drive cfg' putMsg putLog recv_ rest + + p@(Partial _) -> do + recv_ >>= \case + Nothing -> do + putLog $ SGR [34,1] (Plain "# EOL") + Just msg -> + go (feed p msg) + + f@(Fail _i _errorContexts _errMessage) -> + putLog $ SGR [31,1] (Plain (BS.pack $ show f)) + +handleMessage :: Config + -> (Message -> IO ()) + -> (Blessings BS.ByteString -> IO ()) + -> Message + -> IO Config +handleMessage cfg putMsg putLog msg = do + let + q0 = PluginState { + s_putLog = putLog, + s_nick = nick cfg, + s_sendMsg = sendIO putLog putMsg, + s_sendMsg' = sendIO' putLog putMsg + } + + f q i = + execStateT (pluginFunc (either undefined id (pi_plugin i)) msg) q + + q' <- foldM f q0 (pluginInstances cfg) + + return cfg { nick = s_nick q' } + + +formatMessage :: Message -> BS.ByteString +formatMessage (Message mb_prefix cmd params) = + maybe "" (\x -> ":" <> x <> " ") mb_prefix + <> cmd + <> BS.concat (map (" "<>) (init params)) + <> if null params then "" else " :" <> last params + <> "\r\n" + + +getTimestamp :: IO String +getTimestamp = + formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") + . systemToUTCTime <$> getSystemTime + + +newRelay :: IO (a -> IO (), IO a) +newRelay = (putMVar &&& takeMVar) <$> newEmptyMVar + + +newSemaphore :: IO (IO (), IO ()) +newSemaphore = first ($()) <$> newRelay + + +sendIO :: (Blessings BS.ByteString -> IO ()) + -> (Message -> IO ()) + -> Message + -> IO () +sendIO putLog putMsg msg = + sendIO' putLog putMsg msg msg + +sendIO' :: (Blessings BS.ByteString -> IO ()) + -> (Message -> IO ()) + -> Message + -> Message + -> IO () +sendIO' putLog putMsg msg logMsg = do + putLog $ SGR [38,5,235] "> " <> SGR [35,1] (Plain $ formatMessage logMsg) + putMsg msg diff --git a/src/Reaktor/Config.hs b/src/Reaktor/Config.hs new file mode 100644 index 0000000..8330be9 --- /dev/null +++ b/src/Reaktor/Config.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Config where + +import Data.Aeson +import qualified Data.HashMap.Lazy as HML +import qualified Data.Text as T +import qualified Reaktor.Plugins +import Reaktor.Types + + +instance FromJSON Config where + parseJSON (Object v) = do + p <- v .:? "port" .!= defaultPort + + Config + <$> v .: "hostname" + <*> pure p + <*> v .: "nick" + <*> v .:? "useTLS" .!= (p == tlsPort) + <*> v .:? "logTime" .!= True + <*> v .:? "plugins" .!= [] + parseJSON _ = pure undefined + + +data Config = Config { + hostname :: HostName, + port :: ServiceName, + nick :: Nickname, + useTLS :: Bool, + logTime :: Bool, + pluginInstances :: [PluginInstance] + } + + +addPlugin :: T.Text -> IO Plugin -> Config -> Config +addPlugin name p r = + r { pluginInstances = pluginInstances r <> [PluginInstance name (Left p)] } + + +defaultPort :: ServiceName +defaultPort = tlsPort + +tlsPort :: ServiceName +tlsPort = "6697" + + +data PluginInstance = PluginInstance { + pi_name :: T.Text, + pi_plugin :: Either (IO Plugin) Plugin + } + +instance FromJSON PluginInstance where + parseJSON o@(Object v) = + case HML.lookup "plugin" v of + Just (String name) -> do + let p = Reaktor.Plugins.get name + c = HML.lookupDefault (Object HML.empty) "config" v + pure $ PluginInstance name (Left $ p c) + Just _ -> error ("bad plugin object: " <> show o) + _ -> error ("mising 'plugin' attribute: " <> show o) + parseJSON x = + error ("bad plugin type: " <> show x) + + +initPlugins :: Config -> IO Config +initPlugins cfg = do + plugins' <- mapM initPlugin (pluginInstances cfg) + return cfg { pluginInstances = plugins' } + where + initPlugin :: PluginInstance -> IO PluginInstance + initPlugin i = do + p <- + case pi_plugin i of + Right p -> return p + Left f -> f + return i { pi_plugin = Right p } diff --git a/src/Reaktor/Message.hs b/src/Reaktor/Message.hs new file mode 100644 index 0000000..f929471 --- /dev/null +++ b/src/Reaktor/Message.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Message where + +import qualified Data.ByteString.Char8 as BS +import Reaktor.Types + + +privmsg :: BS.ByteString -> [BS.ByteString] -> Message +privmsg msgtarget xs = + Message Nothing "PRIVMSG" (msgtarget:BS.intercalate " " xs:[]) + +notice :: BS.ByteString -> [BS.ByteString] -> Message +notice msgtarget xs = + Message Nothing "NOTICE" (msgtarget:BS.intercalate " " xs:[]) diff --git a/src/Reaktor/Parser.hs b/src/Reaktor/Parser.hs new file mode 100644 index 0000000..bdd2f98 --- /dev/null +++ b/src/Reaktor/Parser.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Parser where + +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 +import qualified Data.ByteString.Char8 as BS +import qualified Data.Char +import Reaktor.Types + + +prefix :: Parser Prefix +prefix = BS.pack <$> many (satisfy Data.Char.isAlphaNum <|> + satisfy (flip elem (":.-@/!~[]\\`_^{|}" :: String))) + +command :: Parser Command +command = BS.pack <$> many1 (satisfy Data.Char.isAlphaNum) + +nospcrlfcl :: Parser Char +nospcrlfcl = + satisfy (flip notElem ("\NUL\CR\LF :" :: String)) <?> "nospcrlfcl" + +middle :: Parser Param +middle = + BS.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl)) + <?> "middle" + +trailing :: Parser Param +trailing = + BS.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl) + <?> "trailing" + +params :: Parser [Param] +params = (do + a <- many (char ' ' *> middle) + b <- optional (char ' ' *> char ':' *> trailing) + return $ a <> (maybe [] (:[]) b)) + <?> "params" + +message :: Parser Message +message = + Message + <$> optional (char ':' *> prefix <* char ' ') + <*> command + <*> params + <* string "\r\n" diff --git a/src/Reaktor/Plugins.hs b/src/Reaktor/Plugins.hs new file mode 100644 index 0000000..83677bb --- /dev/null +++ b/src/Reaktor/Plugins.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins (get,registry) where + +import Data.Aeson (Value) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Reaktor.Plugins.Mention +import qualified Reaktor.Plugins.NickServ +import qualified Reaktor.Plugins.Ping +import qualified Reaktor.Plugins.Register +import qualified Reaktor.Plugins.System +import Reaktor.Types (Plugin) + + +get :: T.Text -> Value -> IO Plugin +get name = + case M.lookup name registry of + Just p -> p + Nothing -> error ("unknown plugin: " <> T.unpack name) + +registry :: M.Map T.Text (Value -> IO Plugin) +registry = M.fromList [ + ("mention", Reaktor.Plugins.Mention.plugin), + ("NickServ", Reaktor.Plugins.NickServ.plugin), + ("ping", Reaktor.Plugins.Ping.plugin), + ("register", Reaktor.Plugins.Register.plugin), + ("system", Reaktor.Plugins.System.plugin) + ] diff --git a/src/Reaktor/Plugins/Mention.hs b/src/Reaktor/Plugins/Mention.hs new file mode 100644 index 0000000..0c86d74 --- /dev/null +++ b/src/Reaktor/Plugins/Mention.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.Mention (plugin) where + +import Control.Monad (when) +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.Char +import Reaktor.Message +import Reaktor.Types + + +plugin :: Value -> IO Plugin +plugin _ = return (Plugin run False) + + +run :: PluginFunc +run = \case + Message _ "PRIVMSG" (msgtarget:text:[]) -> do + nick <- getNick + when (isMention nick text) $ do + sendMsg (privmsg msgtarget ["I'm famous!"]) + _ -> return () + where + isMention nick text = + not (BS.isPrefixOf (nick <> ":") text) && + any (==nick) (BS.splitWith (not . Data.Char.isAlphaNum) text) diff --git a/src/Reaktor/Plugins/NickServ.hs b/src/Reaktor/Plugins/NickServ.hs new file mode 100644 index 0000000..3987774 --- /dev/null +++ b/src/Reaktor/Plugins/NickServ.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.NickServ (plugin) where + +import Control.Monad (when) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Char8 as BS +import GHC.Generics +import Reaktor.Message +import Reaktor.Types +import Reaktor.Utils (randomNick) + + +data NickServConfig = NickServConfig { + passFile :: FilePath, + prefix :: BS.ByteString, + channels :: [BS.ByteString] + } + deriving (FromJSON,Generic) + + +plugin :: Value -> IO Plugin +plugin v = + case parseEither parseJSON v of + Right cfg -> do + pass <- do + [pass] <- lines <$> readFile (passFile cfg) + return (BS.pack pass) + + return $ Plugin (run pass cfg) True + Left err -> + error err + + +run :: BS.ByteString -> NickServConfig -> PluginFunc +run pass cfg msg = do + nick_ <- getNick + case msg of + + Message _ "<start>" _ -> do + nick0 <- lift randomNick + sendMsg (Message Nothing "NICK" [nick0]) + sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_]) + + -- TODO structured prefix, and check just for "NickServ" + Message (Just _prefix@"NickServ!NickServ@services.") + "NOTICE" + (_msgtarget:text:[]) -> do + if + | text == "You are now identified for \STX" <> nick_ <> "\STX." -> do + sendMsg (Message Nothing "NICK" [nick_]) + | text == "\STX" <> nick_ <> "\STX has been released." -> do + sendMsg (Message Nothing "NICK" [nick_]) + | text == "Invalid password for \STX" <> nick_ <> "\STX." -> do + error (BS.unpack text) + | text == "\STX" <> nick_ <> "\STX is not a registered nickname." -> do + error (BS.unpack text) + | otherwise -> + return () + + + Message (Just _self) "NICK" (newnick:[]) -> do + when (newnick == nick_) $ do + -- TODO JOIN only if not already joined + -- i.e. not during subsequent nick changes + sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ]) + + + -- RFC1459 ERR_NICKNAMEINUSE + Message (Just _servername) "433" (_msgtarget:nickinuse:_reason:[]) -> do + if nickinuse == nick_ + then do + sendMsg (privmsg "NickServ" ["RELEASE", nickinuse]) + else do + nick0 <- lift randomNick + sendMsg (Message Nothing "NICK" [nick0]) + + --RFC2812 ERR_UNAVAILRESOURCE + Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do + when (nickunavail == nick_) $ do + sendMsg (privmsg "NickServ" ["RELEASE", nickunavail]) + + --RFC2812 RPL_WELCOME + Message _ "001" [_nick,_s] -> do + sendMsg' (privmsg "NickServ" ["IDENTIFY", nick_, pass]) + (privmsg "NickServ" ["IDENTIFY", nick_, "<password>"]) + + + _ -> return () diff --git a/src/Reaktor/Plugins/Ping.hs b/src/Reaktor/Plugins/Ping.hs new file mode 100644 index 0000000..83b3ac4 --- /dev/null +++ b/src/Reaktor/Plugins/Ping.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.Ping (plugin) where + +import Control.Monad (when) +import Data.Aeson (Value(Null)) +import Reaktor.Types + + +plugin :: Value -> IO Plugin +plugin = simplePlugin (\Null -> run) + +run :: PluginFunc +run (Message _ ircCommand args) = + when (ircCommand == "PING") $ + sendMsg (Message Nothing "PONG" args) diff --git a/src/Reaktor/Plugins/Register.hs b/src/Reaktor/Plugins/Register.hs new file mode 100644 index 0000000..fd17f48 --- /dev/null +++ b/src/Reaktor/Plugins/Register.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.Register (plugin) where + +import Control.Monad (when) +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import GHC.Generics +import Reaktor.Types +import Reaktor.Utils (nextNick,randomNick) + + +data RegisterConfig = RegisterConfig { + channels :: [BS.ByteString] + } + deriving (FromJSON,Generic) + + +plugin :: Value -> IO Plugin +plugin = simplePlugin run + + +run :: RegisterConfig -> PluginFunc +run cfg msg = do + nick_ <- getNick + case msg of + + Message _ "<start>" _ -> do + sendMsg (Message Nothing "NICK" [nick_]) + sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_]) + + Message (Just _self) "NICK" (newnick:[]) -> do + when (newnick == nick_) $ do + -- TODO JOIN only if not already joined + -- i.e. not during subsequent nick changes + sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ]) + + -- RFC1459 ERR_NICKNAMEINUSE + Message (Just _servername) "433" (_msgtarget:nickinuse:_reason:[]) -> do + if nickinuse == nick_ then do + let nick' = nextNick nickinuse + sendMsg (Message Nothing "NICK" [nick']) + -- TODO change state on "NICK" + setNick nick' + + -- TODO is this just for NickServ? (also check that module if it has + -- stuff only for "Register") + else do + nick' <- lift randomNick + sendMsg (Message Nothing "NICK" [nick']) + -- TODO set nick on "NICK" message + setNick nick' + + -- RFC2812 ERR_UNAVAILRESOURCE + --Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do + + -- RFC2812 RPL_WELCOME + Message _ "001" [_nick,_s] -> do + --logStrLn $ SGR [32,1] (Plain s) + sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ]) + + + _ -> return () diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs new file mode 100644 index 0000000..c8d40be --- /dev/null +++ b/src/Reaktor/Plugins/System.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.System (plugin) where + +import Blessings +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Exception (finally) +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as M +import Reaktor.Message +import Reaktor.Plugins.System.Types +import Reaktor.Types +import System.Environment (getEnvironment) +import System.FilePath.Posix (takeBaseName) +import System.IO (Handle,hClose,hPutStr,hIsEOF) +import System.IO (BufferMode(LineBuffering),hSetBuffering) +import System.Process (StdStream(CreatePipe),waitForProcess) +import System.Process (createProcess,CreateProcess(..),proc) +import qualified Text.Regex.PCRE.Heavy as RE +import qualified Text.Regex.PCRE.Light as RE + + +plugin :: Value -> IO Plugin +plugin = simplePlugin run + + +-- TODO indicated whether other plugins should run +run :: SystemConfig -> PluginFunc + +run cfg (Message (Just prefix) "PRIVMSG" (msgtarget:text:[])) = do + nick_ <- getNick + let hs = maybe [] id (M.lookup "PRIVMSG" (hooks cfg)) + mapM_ (\h -> run1 cfg nick_ h prefix msgtarget text) hs + +run cfg (Message (Just prefix) "JOIN" (channel:[])) = do + nick_ <- getNick + let hs = maybe [] id (M.lookup "JOIN" (hooks cfg)) + mapM_ (\h -> run1 cfg nick_ h prefix channel "") hs + +-- TODO warning? +run _ _ = return () + + +run1 :: + SystemConfig + -> Nickname + -> SystemParams + -> BS.ByteString + -> BS.ByteString + -> BS.ByteString + -> PluginIO () +run1 cfg nick_ params prefix msgtarget text = do + let + isActivated = + case activate params of + Always -> Just "" + Match -> + case pattern params of + Nothing -> Nothing + Just pat -> + let + result = RE.scan patternRE text + patternRE = RE.compile pat [] + in + if null result + then Nothing + else Just "" + Query -> + if + | BS.isPrefixOf (nick_ <> ":") text -> + Just (nick_ <> ":") + | BS.isPrefixOf "*:" text -> + Just "*:" + | isQuery -> + Just "" + | otherwise -> + Nothing + + audience = if isQuery then from else msgtarget + + -- 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 + case isActivated of + Just trigger -> do + let cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text + resultPrefix = if isQuery then [] else [from <> ":"] + + parseCommandLine' pat s = + if null result then [] else snd (head result) + where + 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 + sendMsg_ <- gets s_sendMsg + putLog_ <- gets s_putLog + let onErrLine s = + putLog_ $ SGR [31,1] $ + Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s) + + onOutLine s = + sendMsg_ (privmsg audience [s]) + + extraEnv = [("_prefix", BS.unpack prefix), + ("_from", BS.unpack from)] + + lift $ fork cfg c args' (Just extraEnv) "" onOutLine onErrLine + + Nothing -> do + sendMsg (privmsg audience (resultPrefix <> [cmdName <> ": command not found"])) + + Nothing -> return () + + + +fork :: SystemConfig + -> SystemCommand + -> [String] + -> Maybe [(String, String)] + -> String + -> (BS.ByteString -> IO ()) + -> (BS.ByteString -> IO ()) + -> IO () +fork cfg 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 <|> defaultWorkDir cfg, + 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 + ] + + +hWithLines :: Handle -> (BS.ByteString -> IO ()) -> IO () +hWithLines h f = do + hSetBuffering h LineBuffering + go `finally` hClose h + where + go = + hIsEOF h >>= \case + True -> return () + False -> BS.hGetLine h >>= f >> go diff --git a/src/Reaktor/Plugins/System/Types.hs b/src/Reaktor/Plugins/System/Types.hs new file mode 100644 index 0000000..48ec51a --- /dev/null +++ b/src/Reaktor/Plugins/System/Types.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +module Reaktor.Plugins.System.Types where + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as M +import Reaktor.Types () + + +-- TODO this needs better names :) +data CaptureOr a = Capture Integer | CaptureOr a + deriving Show -- TODO killme + +instance FromJSON a => FromJSON (CaptureOr a) where + parseJSON o@(Number _) = Capture <$> parseJSON o -- TODO don't parse twice + parseJSON o = CaptureOr <$> parseJSON o + +-- TODO query means via direct privmsg and <nick>: +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 + +data SystemConfig = SystemConfig { + defaultWorkDir :: Maybe FilePath, + -- TODO IrcCommand as key for map + hooks :: M.Map BS.ByteString [SystemParams] +} + +instance FromJSON SystemConfig where + parseJSON (Object v) = + SystemConfig + <$> 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 + +instance FromJSON SystemCommand where + parseJSON (Object v) = + SystemCommand + <$> v .: "filename" + <*> v .:? "workdir" + <*> v .:? "env" + parseJSON _ = pure undefined + diff --git a/src/Reaktor/Types.hs b/src/Reaktor/Types.hs new file mode 100644 index 0000000..f2115be --- /dev/null +++ b/src/Reaktor/Types.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Reaktor.Types (module Reaktor.Types, module X) where + +import Blessings (Blessings) +import Control.Monad.Trans.Class as X (lift) +import Control.Monad.Trans.State as X (gets,modify) +import Control.Monad.Trans.State (StateT) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text.Encoding as T +import Network.Socket as X (HostName,ServiceName) + + +type Prefix = BS.ByteString + +type Nickname = BS.ByteString +type Password = BS.ByteString +type MsgTarget = BS.ByteString +type Channel = MsgTarget + +data PluginState = PluginState { + s_putLog :: Blessings BS.ByteString -> IO (), + s_nick :: BS.ByteString, + s_sendMsg :: Message -> IO (), + s_sendMsg' :: Message -> Message -> IO () + } + +setNick :: Nickname -> PluginIO () +setNick newnick = modify (\q -> q { s_nick = newnick }) + +getNick :: PluginIO Nickname +getNick = gets s_nick + +sendMsg :: Message -> PluginIO () +sendMsg msg = gets s_sendMsg >>= \f -> lift $ f msg + +sendMsg' :: Message -> Message -> PluginIO () +sendMsg' msg logMsg = gets s_sendMsg' >>= \f -> lift $ f msg logMsg + + +type PluginIO = StateT PluginState IO + +type PluginFunc = Message -> PluginIO () + +data Plugin = Plugin { + pluginFunc :: PluginFunc, + requireTLS :: Bool + } + +simplePlugin :: FromJSON a => (a -> PluginFunc) -> Value -> IO Plugin +simplePlugin f v = + either error (\x -> return $ Plugin (f x) False) (parseEither parseJSON v) + + +type Param = BS.ByteString +type Command = BS.ByteString +data Message = Message (Maybe Prefix) Command [Param] + deriving Show + + +instance FromJSON BS.ByteString where + parseJSON (String t) = pure (T.encodeUtf8 t) + parseJSON _ = pure undefined + +instance FromJSONKey B |