From ce276eee82ec0b8c4106beb4c51d6f9eb77335c4 Mon Sep 17 00:00:00 2001 From: tv Date: Sun, 13 Jan 2019 23:52:05 +0100 Subject: src: init --- src/Reaktor/Config.hs | 76 +++++++++++++ src/Reaktor/Message.hs | 14 +++ src/Reaktor/Parser.hs | 45 ++++++++ src/Reaktor/Plugins.hs | 28 +++++ src/Reaktor/Plugins/Mention.hs | 27 +++++ src/Reaktor/Plugins/NickServ.hs | 92 ++++++++++++++++ src/Reaktor/Plugins/Ping.hs | 15 +++ src/Reaktor/Plugins/Register.hs | 65 +++++++++++ src/Reaktor/Plugins/System.hs | 213 ++++++++++++++++++++++++++++++++++++ src/Reaktor/Plugins/System/Types.hs | 75 +++++++++++++ src/Reaktor/Types.hs | 68 ++++++++++++ src/Reaktor/Utils.hs | 37 +++++++ 12 files changed, 755 insertions(+) create mode 100644 src/Reaktor/Config.hs create mode 100644 src/Reaktor/Message.hs create mode 100644 src/Reaktor/Parser.hs create mode 100644 src/Reaktor/Plugins.hs create mode 100644 src/Reaktor/Plugins/Mention.hs create mode 100644 src/Reaktor/Plugins/NickServ.hs create mode 100644 src/Reaktor/Plugins/Ping.hs create mode 100644 src/Reaktor/Plugins/Register.hs create mode 100644 src/Reaktor/Plugins/System.hs create mode 100644 src/Reaktor/Plugins/System/Types.hs create mode 100644 src/Reaktor/Types.hs create mode 100644 src/Reaktor/Utils.hs (limited to 'src/Reaktor') 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 _ "" _ -> 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_, ""]) + + + _ -> 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 _ "" _ -> 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 -> "" + 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 : +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 BS.ByteString where + fromJSONKey = FromJSONKeyText T.encodeUtf8 diff --git a/src/Reaktor/Utils.hs b/src/Reaktor/Utils.hs new file mode 100644 index 0000000..bc08a81 --- /dev/null +++ b/src/Reaktor/Utils.hs @@ -0,0 +1,37 @@ +module Reaktor.Utils where + +import qualified Data.ByteString.Char8 as BS +import Data.Char (chr) +import Data.Char (isDigit) +import Reaktor.Types +import System.Random (getStdRandom, randomR) + + +nextNick :: Nickname -> Nickname +nextNick nick_ = nick' + where + splitNick s = + (prefix, maybe 0 fst (BS.readInt suffix)) + where + prefix = BS.take (BS.length s - BS.length suffix) s + suffix = BS.reverse . BS.takeWhile isDigit . BS.reverse $ s + (nickPrefix, nickSuffix) = splitNick nick_ + nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1) + + +randomNick :: IO Nickname +randomNick = do + h_chr <- getRandomChar nickhead + t_len <- getStdRandom (randomR (4,8)) :: IO Int + t_str <- mapM (const $ getRandomChar nicktail) [1..t_len] + return $ BS.pack (h_chr:t_str) + where + getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1)) + + nickhead = letters <> specials + nicktail = letters <> digits <> specials <> minus + + letters = map chr $ [0x41..0x5A] <> [0x61..0x7A] + digits = map chr $ [0x30..0x39] + specials = map chr $ [0x5B..0x60] <> [0x7B..0x7D] + minus = map chr $ [0x2D] -- cgit v1.2.3