From d40815fd56bf1895af89b72b1171675a2e0ae5f7 Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 23 Jan 2019 00:02:42 +0100 Subject: src: use more simple functions --- src/Reaktor/Plugins/Mention.hs | 28 +++-- src/Reaktor/Plugins/NickServ.hs | 92 ---------------- src/Reaktor/Plugins/Ping.hs | 28 ++--- src/Reaktor/Plugins/Register.hs | 188 +++++++++++++++++++++++++-------- src/Reaktor/Plugins/System.hs | 101 ++++++++---------- src/Reaktor/Plugins/System/Internal.hs | 18 ++-- 6 files changed, 226 insertions(+), 229 deletions(-) delete mode 100644 src/Reaktor/Plugins/NickServ.hs (limited to 'src/Reaktor/Plugins') 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 _ "" _ -> 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 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, ""]) + 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 _ "" _ -> 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, ""]) + 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 parseJSON (Object v) = - SystemConfig + Config <$> v .:? "workdir" <*> v .:? "hooks" .!= M.empty parseJSON _ = pure undefined -- cgit v1.2.3