diff options
Diffstat (limited to 'src/Reaktor')
| -rw-r--r-- | src/Reaktor/Config.hs | 76 | ||||
| -rw-r--r-- | src/Reaktor/Internal.hs | 102 | ||||
| -rw-r--r-- | src/Reaktor/Message.hs | 14 | ||||
| -rw-r--r-- | src/Reaktor/Nick.hs (renamed from src/Reaktor/Utils.hs) | 29 | ||||
| -rw-r--r-- | src/Reaktor/Parser.hs | 20 | ||||
| -rw-r--r-- | src/Reaktor/Plugins.hs | 28 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Mention.hs | 28 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/NickServ.hs | 92 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Ping.hs | 28 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/Register.hs | 188 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System.hs | 101 | ||||
| -rw-r--r-- | src/Reaktor/Plugins/System/Internal.hs | 18 |
12 files changed, 311 insertions, 413 deletions
diff --git a/src/Reaktor/Config.hs b/src/Reaktor/Config.hs deleted file mode 100644 index 908f9a8..0000000 --- a/src/Reaktor/Config.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reaktor.Config where - -import Data.Aeson -import qualified Data.HashMap.Lazy as HML -import qualified Data.Text as T -import Reaktor.Internal -import qualified Reaktor.Plugins - - -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/Internal.hs b/src/Reaktor/Internal.hs index d3ac9cf..26294b4 100644 --- a/src/Reaktor/Internal.hs +++ b/src/Reaktor/Internal.hs @@ -1,58 +1,68 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Internal (module Reaktor.Internal, 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 +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Internal where + +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 Network.Socket as X (HostName,ServiceName) +import System.IO -type Prefix = BS.ByteString +data Actions = Actions + { aIsSecure :: Bool -type Nickname = BS.ByteString -type Password = BS.ByteString -type MsgTarget = BS.ByteString -type Channel = MsgTarget + , aSend :: Message -> IO () + , aSendQuiet :: Message -> IO () -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 + , aLog :: Blessings ByteString -> IO () + , aLogMsg :: Message -> IO () - -type PluginIO = StateT PluginState IO - -type PluginFunc = Message -> PluginIO () - -data Plugin = Plugin { - pluginFunc :: PluginFunc, - requireTLS :: Bool + , aSetNick :: ByteString -> IO () + , aGetNick :: IO ByteString } -simplePlugin :: FromJSON a => (a -> PluginFunc) -> Value -> IO Plugin -simplePlugin f v = - either error (\x -> return $ Plugin (f x) False) (parseEither parseJSON v) +data Config = Config + { cUseTLS :: Bool + , cHostName :: HostName + , cServiceName :: ServiceName + , cNick :: Maybe ByteString + , cLogHandle :: Handle + , cLogTime :: Bool + } -type Param = BS.ByteString -type Command = BS.ByteString -data Message = Message (Maybe Prefix) Command [Param] +instance Default Config where + def = Config False "irc.r" "6667" Nothing stderr True + +instance FromJSON Config where + parseJSON = \case + Object v -> do + cServiceName <- v .:? "port" .!= cServiceName def + cUseTLS <- v .:? "useTLS" .!= (cServiceName == tlsPort) + cHostName <- v .:? "hostname" .!= cHostName def + cNick <- v .:? "nick" + cLogHandle <- pure (cLogHandle def) + cLogTime <- v .:? "logTime" .!= cLogTime def + pure Config{..} + _ -> undefined + where + tlsPort :: ServiceName + tlsPort = "6697" + + +data Message = Message (Maybe ByteString) ByteString [ByteString] | Start deriving Show + +formatMessage :: Message -> ByteString +formatMessage = \case + Message mb_prefix cmd params -> + maybe "" ((":"<>) . (<>" ")) mb_prefix + <> cmd + <> BS.concat (map (" "<>) (init params)) + <> if null params then "" else " :" <> last params + <> "\r\n" + x -> error ("cannot format " <> show x) diff --git a/src/Reaktor/Message.hs b/src/Reaktor/Message.hs deleted file mode 100644 index c679d78..0000000 --- a/src/Reaktor/Message.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reaktor.Message where - -import qualified Data.ByteString.Char8.Extended as BS -import Reaktor.Internal - - -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/Utils.hs b/src/Reaktor/Nick.hs index a31cd15..591ea4b 100644 --- a/src/Reaktor/Utils.hs +++ b/src/Reaktor/Nick.hs @@ -1,14 +1,14 @@ -module Reaktor.Utils where +module Reaktor.Nick where +import Data.ByteString.Char8.Extended (ByteString) import qualified Data.ByteString.Char8.Extended as BS import Data.Char (chr) import Data.Char (isDigit) -import Reaktor.Internal import System.Random (getStdRandom, randomR) -nextNick :: Nickname -> Nickname -nextNick nick_ = nick' +getNext :: ByteString -> ByteString +getNext nick_ = nick' where splitNick s = (prefix, maybe 0 fst (BS.readInt suffix)) @@ -19,8 +19,8 @@ nextNick nick_ = nick' nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1) -randomNick :: IO Nickname -randomNick = do +getRandom :: IO ByteString +getRandom = do h_chr <- getRandomChar nickhead t_len <- getStdRandom (randomR (4,8)) :: IO Int t_str <- mapM (const $ getRandomChar nicktail) [1..t_len] @@ -28,10 +28,17 @@ randomNick = do where getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1)) - nickhead = letters <> specials - nicktail = letters <> digits <> specials <> minus + -- RFC2812 (doesn't work with charybdis) + --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] + -- RFC1459 + nickhead = letters + nicktail = letters <> number <> special letters = map chr $ [0x41..0x5A] <> [0x61..0x7A] - digits = map chr $ [0x30..0x39] - specials = map chr $ [0x5B..0x60] <> [0x7B..0x7D] - minus = map chr $ [0x2D] + number = map chr $ [0x30..0x39] + special = map chr $ [0x5B..0x60] <> [0x7B..0x7D] <> [0x2D] diff --git a/src/Reaktor/Parser.hs b/src/Reaktor/Parser.hs index 12d5ace..1b358fc 100644 --- a/src/Reaktor/Parser.hs +++ b/src/Reaktor/Parser.hs @@ -1,35 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} module Reaktor.Parser where -import Control.Applicative -import Data.Attoparsec.ByteString.Char8 -import qualified Data.ByteString.Char8.Extended as BS +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Attoparsec.ByteString.Char8 +--import qualified Data.ByteString.Char8.Extended as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.Char -import Reaktor.Internal +import Reaktor.Internal -prefix :: Parser Prefix +prefix :: Parser ByteString prefix = BS.pack <$> many (satisfy Data.Char.isAlphaNum <|> satisfy (flip elem (":.-@/!~[]\\`_^{|}" :: String))) -command :: Parser Command +command :: Parser ByteString command = BS.pack <$> many1 (satisfy Data.Char.isAlphaNum) nospcrlfcl :: Parser Char nospcrlfcl = satisfy (flip notElem ("\NUL\CR\LF :" :: String)) <?> "nospcrlfcl" -middle :: Parser Param +middle :: Parser ByteString middle = BS.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl)) <?> "middle" -trailing :: Parser Param +trailing :: Parser ByteString trailing = BS.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl) <?> "trailing" -params :: Parser [Param] +params :: Parser [ByteString] params = (do a <- many (char ' ' *> middle) b <- optional (char ' ' *> char ':' *> trailing) diff --git a/src/Reaktor/Plugins.hs b/src/Reaktor/Plugins.hs deleted file mode 100644 index 86e1f2a..0000000 --- a/src/Reaktor/Plugins.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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.Internal (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 index 75de87c..379bd38 100644 --- a/src/Reaktor/Plugins/Mention.hs +++ b/src/Reaktor/Plugins/Mention.hs @@ -1,26 +1,22 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Mention (plugin) where +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Mention (new) where -import Control.Monad (when) -import Data.Aeson +import Prelude.Extended import qualified Data.ByteString.Char8.Extended as BS import qualified Data.Char -import Reaktor.Internal -import Reaktor.Message +import Reaktor -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 () +new :: Actions -> IO (Message -> IO ()) +new Actions{..} = do + pure $ \case + Message _ "PRIVMSG" (msgtarget:text:[]) -> do + nick <- aGetNick + when (isMention nick text) $ do + aSend (privmsg msgtarget ["I'm famous!"]) + _ -> return () where isMention nick text = not (BS.isPrefixOf (nick <> ":") text) && diff --git a/src/Reaktor/Plugins/NickServ.hs b/src/Reaktor/Plugins/NickServ.hs deleted file mode 100644 index 36b8917..0000000 --- a/src/Reaktor/Plugins/NickServ.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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.Extended as BS -import GHC.Generics -import Reaktor.Internal -import Reaktor.Message -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 index de3fe53..436ebe2 100644 --- a/src/Reaktor/Plugins/Ping.hs +++ b/src/Reaktor/Plugins/Ping.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Ping (plugin) where - -import Control.Monad (when) -import Data.Aeson (Value(Null)) -import Reaktor.Internal - - -plugin :: Value -> IO Plugin -plugin = simplePlugin (\Null -> run) - -run :: PluginFunc -run (Message _ ircCommand args) = - when (ircCommand == "PING") $ - sendMsg (Message Nothing "PONG" args) +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Ping where + +import Prelude.Extended +import Reaktor + +new :: Actions -> IO (Message -> IO ()) +new Actions{..} = + return $ \case + Message _ cmd args -> + when (cmd == "PING") $ + aSend (Message Nothing "PONG" args) + _ -> pure () diff --git a/src/Reaktor/Plugins/Register.hs b/src/Reaktor/Plugins/Register.hs index 5e987a7..314fc6f 100644 --- a/src/Reaktor/Plugins/Register.hs +++ b/src/Reaktor/Plugins/Register.hs @@ -1,65 +1,163 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Register (plugin) where +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Register where -import Control.Monad (when) -import Data.Aeson +import Blessings +import Prelude.Extended +import Data.Aeson +import Data.ByteString.Char8.Extended (ByteString) import qualified Data.ByteString.Char8.Extended as BS -import GHC.Generics -import Reaktor.Internal -import Reaktor.Utils (nextNick,randomNick) +import qualified Reaktor.Nick as Nick +import Reaktor +import System.Environment (lookupEnv) +data ConfigNickServ = ConfigNickServ + { cnsPassFile :: FilePath + , cnsPrefix :: ByteString + } +instance FromJSON ConfigNickServ where + parseJSON = \case + Object v -> + ConfigNickServ + <$> v .: "passFile" + <*> v .:? "prefix" .!= "NickServ!NickServ@services." + _ -> undefined -data RegisterConfig = RegisterConfig { - channels :: [BS.ByteString] +data Config = Config + { cNick :: Maybe ByteString + , cUser :: Maybe ByteString + , cReal :: ByteString + , cChannels :: [ByteString] + , cNickServ :: Maybe ConfigNickServ } - deriving (FromJSON,Generic) +instance Default Config where + def = Config def def "reaktor2" def def +instance FromJSON Config where + parseJSON = \case + Object v -> do + cNick <- v .:? "nick" .!= Nothing + cUser <- v .:? "user" + cReal <- v .:? "real" .!= cReal def + cChannels <- v .:? "channels" .!= [] + cNickServ <- v .:? "NickServ" .!= cNickServ def + pure Config{..} + _ -> undefined + +new :: Config -> Actions -> IO (Message -> IO ()) +new Config{..} Actions{..} = do + let + isNickServEnabled = aIsSecure && isJust cNickServ + Just ConfigNickServ{..} = cNickServ + + release nick pass = do + -- TODO Password type that doesn't get logged? + aLogMsg (privmsg "NickServ" ["RELEASE", nick, "<password>"]) + aSendQuiet (privmsg "NickServ" ["RELEASE", nick, pass]) + channelsArg = BS.intercalate "," cChannels + -- TODO make this similar to privmsg (i.e. don't aSend) + join = do + -- TODO JOIN only if not already joined + -- i.e. not during subsequent nick changes + unless (BS.null channelsArg) $ + aSend (Message Nothing "JOIN" [channelsArg]) -plugin :: Value -> IO Plugin -plugin = simplePlugin run + start = do + nick <- maybe aGetNick pure cNick + user <- + maybe (maybe nick BS.pack <$> lookupEnv "LOGNAME") pure cUser + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + aSend (Message Nothing "USER" [user, "*", "0", cReal]) + onNick newnick = do + nick <- aGetNick + when (newnick == nick) join + useRandomNick = do + nick <- Nick.getRandom + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + useNextNick = do + nick0 <- aGetNick + let nick = Nick.getNext nick0 + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + useNextNickTemporarily = do + nick <- aGetNick + let tmpNick = Nick.getNext nick + -- do not aSetNick tmpNick + aSend (Message Nothing "NICK" [tmpNick]) + if not isNickServEnabled then do + when (isJust cNickServ) $ do + aLog $ SGR [38,5,202] "! disabling NickServ due to insecure connection" + pure $ \case + Start -> start + Message (Just _self) "NICK" (newnick:[]) -> onNick newnick + Message _ "001" _ -> join + Message _ "432" _ -> useRandomNick + Message _ "433" _ -> useNextNick + Message _ "437" (_msgtarget:res:_reason:[]) -> do + nick <- aGetNick + when (res == nick) useNextNick + _ -> pure () -run :: RegisterConfig -> PluginFunc -run cfg msg = do - nick_ <- getNick - case msg of + else do + -- TODO do not fail, but disable NicServ + [pass] <- BS.lines <$> BS.readFile cnsPassFile + pure $ \case + Start -> start + Message (Just _self) "NICK" (newnick:[]) -> onNick newnick - Message _ "<start>" _ -> do - sendMsg (Message Nothing "NICK" [nick_]) - sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_]) + -- RFC2812 RPL_WELCOME + Message _ "001" [msgtarget,_text] -> do + nick <- aGetNick + aLogMsg (privmsg "NickServ" ["IDENTIFY", nick, "<password>"]) + aSendQuiet (privmsg "NickServ" ["IDENTIFY", nick, pass]) + when (msgtarget /= nick) (release nick pass) - 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) ]) + -- TODO structured prefix, and check just for "NickServ"? + Message (Just prefix) "NOTICE" (msgtarget:text:[]) -> + when (prefix == cnsPrefix) $ do + nick <- aGetNick + let stx = ("\STX"<>) . (<>"\STX") + if + | text == "You are now identified for " <> stx nick <> "." -> do + -- XXX if msgtarget == nick then do + -- XXX join + -- XXX else do + -- XXX aSend (Message Nothing "NICK" [nick]) - -- 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' + -- otherwise join at NICK + when (msgtarget == nick) join - -- 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' + | text == stx nick <> " has been released." -> do + aSend (Message Nothing "NICK" [nick]) + | text == "Invalid password for " <> stx nick <> "." -> do + -- TODO change nick + warning + error (BS.unpack text) + | text == stx nick <> " is not a registered nickname." -> do + -- TODO change nick + warning + error (BS.unpack text) + | otherwise -> + pure () - -- RFC2812 ERR_UNAVAILRESOURCE - --Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do + -- RFC1459 ERR_ERRONEUSNICKNAME + Message (Just _servername) "432" (_msgtarget:_nick:_reason:[]) -> + useRandomNick - -- RFC2812 RPL_WELCOME - Message _ "001" [_nick,_s] -> do - --logStrLn $ SGR [32,1] (Plain s) - sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ]) + -- RFC1459 ERR_NICKNAMEINUSE + Message (Just _servername) "433" (_msgtarget:_nick:_reason:[]) -> + -- TODO what if nick0 /= nick? OR assert/prove nick0 == nick? + useNextNickTemporarily + --RFC2812 ERR_UNAVAILRESOURCE + Message (Just _servername) "437" (msgtarget:res:_reason:[]) -> do + nick <- aGetNick + when (res == nick) $ + case msgtarget of + "*" -> useNextNickTemporarily + _ -> release nick pass - _ -> return () + _ -> pure () diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs index 781409b..88b8d84 100644 --- a/src/Reaktor/Plugins/System.hs +++ b/src/Reaktor/Plugins/System.hs @@ -2,58 +2,49 @@ {-# 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 +{-# 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 qualified Data.ByteString.Char8.Extended as BS import qualified Data.Map as M -import Reaktor.Message -import Reaktor.Internal -import Reaktor.Plugins.System.Internal -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 Reaktor +import System.Environment (getEnvironment) +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 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 +new :: Config -> Actions -> IO (Message -> IO ()) +new config@Config{..} actions@Actions{..} = do + pure $ \case + Message (Just prefix) "PRIVMSG" (msgtarget:text:[]) -> do -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 + nick_ <- aGetNick + let hs = maybe [] id (M.lookup "PRIVMSG" cHooks) + mapM_ (\h -> run1 config actions 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 + 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 --- TODO warning? -run _ _ = return () + _ -> pure () -run1 :: - SystemConfig - -> Nickname - -> SystemParams - -> BS.ByteString - -> BS.ByteString - -> BS.ByteString - -> PluginIO () -run1 cfg nick_ params prefix msgtarget text = do +run1 :: Config -> Actions -> ByteString -> SystemParams -> ByteString -> ByteString -> ByteString -> IO () +run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text = do let isActivated = case activate params of @@ -88,6 +79,7 @@ run1 cfg nick_ params prefix msgtarget text = do 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 @@ -141,36 +133,35 @@ run1 cfg nick_ params prefix msgtarget text = do case command' of Just c -> do - sendMsg_ <- gets s_sendMsg - putLog_ <- gets s_putLog + -- aSend <- gets s_sendMsg + -- putLog_ <- gets s_putLog let onErrLine s = - putLog_ $ SGR [31,1] $ + aLog $ SGR [31,1] $ Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s) onOutLine s = - sendMsg_ (privmsg audience [s]) + aSend (privmsg audience [s]) extraEnv = [("_prefix", BS.unpack prefix), ("_from", BS.unpack from)] - lift $ fork cfg c args' (Just extraEnv) "" onOutLine onErrLine + fork config actions c args' (Just extraEnv) "" onOutLine onErrLine Nothing -> do - sendMsg (privmsg audience (resultPrefix <> [cmdName <> ": command not found"])) + aSend (privmsg audience (resultPrefix <> [cmdName <> ": command not found"])) Nothing -> return () - - -fork :: SystemConfig +fork :: Config + -> Actions -> SystemCommand -> [String] -> Maybe [(String, String)] -> String - -> (BS.ByteString -> IO ()) - -> (BS.ByteString -> IO ()) + -> (ByteString -> IO ()) + -> (ByteString -> IO ()) -> IO () -fork cfg cmd args extraEnv input onOutLine onErrLine = do +fork Config{..} Actions{..} cmd args extraEnv input onOutLine onErrLine = do baseEnv <- getEnvironment @@ -183,7 +174,7 @@ fork cfg cmd args extraEnv input onOutLine onErrLine = do (inh, outh, errh) <- do (Just inh, Just outh, Just errh, ph) <- createProcess (proc (commandPath cmd) args) { - cwd = commandWorkDir cmd <|> defaultWorkDir cfg, + cwd = commandWorkDir cmd <|> cDefaultWorkDir, env = Just procEnv, std_in = CreatePipe, std_out = CreatePipe, @@ -202,7 +193,7 @@ fork cfg cmd args extraEnv input onOutLine onErrLine = do ] -hWithLines :: Handle -> (BS.ByteString -> IO ()) -> IO () +hWithLines :: Handle -> (ByteString -> IO ()) -> IO () hWithLines h f = do hSetBuffering h LineBuffering go `finally` hClose h diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs index 4a64e0b..2ed923d 100644 --- a/src/Reaktor/Plugins/System/Internal.hs +++ b/src/Reaktor/Plugins/System/Internal.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Reaktor.Plugins.System.Internal where -import Data.Aeson +import Prelude.Extended +import Data.Aeson import qualified Data.ByteString.Char8.Extended as BS import qualified Data.Map as M -import Reaktor.Internal () +import Reaktor () -- TODO this needs better names :) @@ -24,15 +25,18 @@ instance FromJSON Activate where parseJSON (String "query") = pure Query parseJSON _ = undefined -data SystemConfig = SystemConfig { - defaultWorkDir :: Maybe FilePath, +data Config = Config { + cDefaultWorkDir :: Maybe FilePath, -- TODO IrcCommand as key for map - hooks :: M.Map BS.ByteString [SystemParams] + cHooks :: M.Map BS.ByteString [SystemParams] } -instance FromJSON SystemConfig where +instance Default Config where + def = Config Nothing mempty + +instance FromJSON Config where |