summaryrefslogtreecommitdiffstats
path: root/src/Reaktor/Plugins
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2019-01-23 00:02:42 +0100
committertv <tv@krebsco.de>2019-01-23 00:57:36 +0100
commitd40815fd56bf1895af89b72b1171675a2e0ae5f7 (patch)
tree83b96a701f16b13915836c3a6c94463732a9f6d8 /src/Reaktor/Plugins
parenta00da57346c195b1b15d1c6aca2891483901aae6 (diff)
src: use more simple functions
Diffstat (limited to 'src/Reaktor/Plugins')
-rw-r--r--src/Reaktor/Plugins/Mention.hs28
-rw-r--r--src/Reaktor/Plugins/NickServ.hs92
-rw-r--r--src/Reaktor/Plugins/Ping.hs28
-rw-r--r--src/Reaktor/Plugins/Register.hs188
-rw-r--r--src/Reaktor/Plugins/System.hs101
-rw-r--r--src/Reaktor/Plugins/System/Internal.hs18
6 files changed, 226 insertions, 229 deletions
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
parseJSON (Object v) =
- SystemConfig
+ Config
<$> v .:? "workdir"
<*> v .:? "hooks" .!= M.empty
parseJSON _ = pure undefined