add irc, add more handlers

This commit is contained in:
Jon Doe 2020-09-26 21:26:42 +02:00 committed by Maciej Bonin
parent 5342dafe3f
commit 6edb35727f
6 changed files with 214 additions and 11 deletions

View File

@ -14,7 +14,7 @@ cabal-version: >=1.10
extra-source-files: README.md extra-source-files: README.md
library library
exposed-modules: GypsFulvus, GypsFulvus.PluginStuff, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL exposed-modules: GypsFulvus, GypsFulvus.PluginStuff, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL, Carrion.Plugin.IO.IRC.Client
other-modules: other-modules:
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: src hs-source-dirs: src
@ -27,7 +27,17 @@ library
hashable, hashable,
monad-parallel, monad-parallel,
haskeline, haskeline,
unix unix,
connection >= 0.3.1,
irc-client,
irc-conduit >= 0.3.0.4,
irc-ctcp >= 0.1.3.0,
lens,
network-conduit-tls >= 1.3.2,
tls >= 1.5.4,
x509-validation >= 1.6.11,
bytestring
extra-libraries: tcl8.6 extra-libraries: tcl8.6
Includes: /usr/include/tcl.h, Includes: /usr/include/tcl.h,
src/tclstubswrapper/tclstubs.h src/tclstubswrapper/tclstubs.h
@ -49,14 +59,24 @@ executable GypsFulvus
hashable, hashable,
monad-parallel, monad-parallel,
haskeline, haskeline,
unix unix,
connection >= 0.3.1,
irc-client,
irc-conduit >= 0.3.0.4,
irc-ctcp >= 0.1.3.0,
lens,
network-conduit-tls >= 1.3.2,
tls >= 1.5.4,
x509-validation >= 1.6.11,
bytestring
ghc-options: ghc-options:
-O2 -O2
-threaded -threaded
-with-rtsopts=-N -with-rtsopts=-N
-g -g
hs-source-dirs: src hs-source-dirs: src
other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL other-modules: GypsFulvus.PluginStuff,GypsFulvus, Carrion.Plugin.IO.STDIO, Carrion.Plugin.TCL, Carrion.Plugin.IO.IRC.Client
exposed-modules: GypsFulvus exposed-modules: GypsFulvus
extra-libraries: tcl8.6 extra-libraries: tcl8.6
Includes: /usr/include/tcl.h, Includes: /usr/include/tcl.h,

View File

@ -0,0 +1,157 @@
{-# LANGUAGE OverloadedStrings #-}
module Carrion.Plugin.IO.IRC.Client
(initPlugin,tellCommands)
where
import GypsFulvus.PluginStuff(Manhole(..),Sewage(..), InitStatus(..),SewageAutorInfo(..),genericAutorToNSAutor,inspectManhole,regift, stripCommandPrefix')
import Network.IRC.Client
import Data.Conduit.Network.TLS
import Network.Connection
import Network.IRC.Conduit
import Network.TLS
import Network.TLS.Extra
import Data.X509.Validation
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import Data.Text.Encoding (decodeUtf8)
import Control.Lens
import Control.Concurrent(threadDelay,forkIO)
import qualified Data.Text as T
import Control.Concurrent.STM
import Control.Monad(liftM)
import Data.Monoid
import qualified Data.Map as M
import Data.ByteString(ByteString)
import Network.IRC.CTCP(CTCPByteString(..))
import Control.Applicative ((<$>), (<|>))
type MyNicknames = M.Map (T.Text) ([T.Text])
a b = T.append a b
unpack = T.unpack
myPlugName :: T.Text
myPlugName = T.pack "IRC-Simple"
lOCAL :: T.Text
lOCAL = T.pack "local"
mySignature = GenericStyleAutor myPlugName lOCAL lOCAL
tellCommands = ["tcl"]
privateBotCommands = ["!join","!part","!kick","!op","!cycle","!reconnect","!ostracise","tcl"]
myOwners = ["hastur"]
myChannels :: [T.Text]
myChannels = ["#exquisitebot"]
-- this dogshit irc library doesnt seem to have a concept of 'people in the channel(s)'
rPL_NAMREPLY :: Int
rPL_NAMREPLY = 353
joinHandler' :: EventHandler s
joinHandler' = EventHandler (\ev -> matchNumeric 331 ev <|> matchNumeric 332 ev) $ \_ args -> case args of
(c:_) -> do
send $ RawMsg $ "NAMES " c
_ -> pure ()
namesReplyHandler
:: a -> TMVar (M.Map T.Text [T.Text]) -> EventHandler s
namesReplyHandler mh nns = huntAlligators (matchNumeric' rPL_NAMREPLY (mh,nns)) $ \src ((mh,nns), (meirl:theEqualsSignAsASeparateElementWhyTheFuckNot:theChan:theNicknames:[])) -> do
-- let fff = (T.breakOn " :" (foldr1 (\a b -> a ♯ " *BOINK* " ♯ b) thetail))
-- (theChan,theNicknames) = fff & _2 %~ (T.splitOn " " . T.drop 1)
grr <- liftIO . atomically $ do
lnns <- takeTMVar nns
let curList = M.lookup theChan lnns
fff = M.insert theChan (case curList of
Nothing -> T.splitOn " " theNicknames
Just cl -> cl ++ (T.splitOn " " theNicknames)) lnns
return fff
liftIO $ putStrLn $ "what the fuck did I just do: " ++ show grr
return ()
matchNumeric'
:: Int -> a1 -> Event a2 -> Maybe (a1, [a2])
matchNumeric' n intruder ev = case _message ev of
Numeric num args | n == num -> Just (intruder,args)
_ -> Nothing
huntCrocodiles
:: Getting (First b) (Message a1) b
-> a2 -> Event a1 -> Maybe (a2, b)
huntCrocodiles k mh ev = case preview k . _message $ ev of
Nothing -> Nothing
Just sth -> Just (mh,sth)
unimplementedCommand :: T.Text
unimplementedCommand = "Command not implemented."
huntAlligators
:: (Event T.Text -> Maybe b)
-> (Source T.Text -> b -> IRC s ()) -> EventHandler s
huntAlligators mf cf = EventHandler mf cf
fYourKickHandler :: Manhole -> EventHandler s
fYourKickHandler mh = huntAlligators (huntCrocodiles _Kick mh) $ \src (mh, (channame, nickname, reason)) -> do
tvarI <- get instanceConfig <$> getIRCState
iGotBooted <- liftIO . atomically $ do
theNick <- get nick <$> readTVar tvarI
return $ case src of
Channel c _
| nickname == theNick -> True
| otherwise -> False
_ -> False
if(iGotBooted) then do
liftIO $ regift (Sewage mySignature (T.pack "got kicked from " channame)) mh
liftIO (threadDelay 10000000)
send $ Join channame
else return ()
spamCoordinator :: Manhole -> T.Text -> IO ()
spamCoordinator mh msg = regift (Sewage mySignature msg) mh
detectCommandHandler :: Manhole -> EventHandler s
detectCommandHandler mh = huntAlligators (huntCrocodiles _Privmsg mh) $ \src (mh,(tgt,blergh)) -> do
tvarI <- get instanceConfig <$> getIRCState
case blergh of
Right body -> do
let theC = ((T.breakOn " " body) ^. _1)
let fff = theC `elem` privateBotCommands
if(fff) then do
mCommand <- liftIO $ stripCommandLocal body mh
case mCommand of
Nothing -> return ()
Just c -> do
liftIO $ spamCoordinator mh body -- actually process the commands here
else return ()
Left _ -> return ()
stripCommandLocal :: T.Text -> Manhole -> IO (Maybe T.Text)
stripCommandLocal c m = stripCommandPrefix' c tellCommands m mySignature
initPlugin :: Manhole -> IO InitStatus
initPlugin mh = do
let myHost = "darkarmy.chat"
myPort = 6697
myNickname = "ExquisiteRobot"
cpara = defaultParamsClient (unpack $ decodeUtf8 myHost) ""
validate cs vc sid cc = do
-- First validate with the standard function
res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc
-- Then strip out non-issues
return $ filter (`notElem` [UnknownCA, SelfSigned]) res
myClientConfig = (tlsClientConfig myPort myHost) { tlsClientTLSSettings = TLSSettings cpara
{ clientHooks = (clientHooks cpara)
{ onServerCertificate = validate }
, clientSupported = (clientSupported cpara)
{ supportedVersions = [TLS12, TLS11, TLS10]
, supportedCiphers = ciphersuite_strong
}
}
}
rejoinOnKickHandler = fYourKickHandler mh
detectCommandHandler' = detectCommandHandler mh
conn = tlsConnection $ WithClientConfig myClientConfig
myNNS <- atomically $ newTMVar M.empty
let namesReplyHandler' = namesReplyHandler mh myNNS
mySpecialHandlers = [rejoinOnKickHandler,detectCommandHandler',joinHandler',namesReplyHandler']
cfg = defaultInstanceConfig myNickname & channels %~ (myChannels ++) & handlers %~ (++ mySpecialHandlers)
forkIO $ runClient conn cfg ()
return GoodInitStatus

View File

@ -127,8 +127,8 @@ initPlugin manhole = do
processCommand :: TCLInterpreterWrapper -> Sewage -> IO T.Text processCommand :: TCLInterpreterWrapper -> Sewage -> Bool -> IO T.Text
processCommand wi s = do processCommand wi s ip = do
let tcl_EvalEx = getEvalEx wi let tcl_EvalEx = getEvalEx wi
tcl_GetStringResult = getGetStringResult wi tcl_GetStringResult = getGetStringResult wi
tcl_CancelEval = getCancelEval wi tcl_CancelEval = getCancelEval wi
@ -150,6 +150,7 @@ processCommand wi s = do
0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then dumpDebug ("Command: " ++ c ++" ; returned a null pointer result.") >> return "FAILED" else peekCString rs >>= \nrs -> dumpDebug ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";") >> return nrs 0 -> tcl_GetStringResult interp >>= \rs -> if nullPtr == rs then dumpDebug ("Command: " ++ c ++" ; returned a null pointer result.") >> return "FAILED" else peekCString rs >>= \nrs -> dumpDebug ("Output of command: " ++ c ++ " ;" ++ nrs ++ ";") >> return nrs
_ -> errorInfo >> tcl_GetStringResult interp >>= peekCString _ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}" performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
performAdminLevel = doTheTCL sewCmd
-- harvester <- forkIO $ do -- harvester <- forkIO $ do
-- threadDelay 15000000 -- threadDelay 15000000
-- putStrLn "cancelling thread!!!" -- putStrLn "cancelling thread!!!"
@ -157,7 +158,7 @@ processCommand wi s = do
-- putStrLn $ "cancel status " ++ (show fff) -- putStrLn $ "cancel status " ++ (show fff)
-- hngggg <- tcl_AsyncInvoke interp 0 -- hngggg <- tcl_AsyncInvoke interp 0
-- putStrLn $ "asyncinvoke returned " ++ (show hngggg) -- putStrLn $ "asyncinvoke returned " ++ (show hngggg)
res <- performFromIRC res <- if (ip) then performAdminLevel else performFromIRC
-- putStrLn "putting back the interp" -- putStrLn "putting back the interp"
atomically $ putTMVar i interp atomically $ putTMVar i interp
return $ T.pack res return $ T.pack res
@ -174,7 +175,8 @@ rEPL wrappedtclinterp manhole =
let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
case hmm of case hmm of
Nothing -> do Nothing -> do
processedGift <- processCommand wrappedtclinterp giftStripped let isPrivileged = if T.pack "tclAdmin " `T.isPrefixOf` (getSewage newGift) then True else False
processedGift <- processCommand wrappedtclinterp giftStripped isPrivileged
regift (Sewage mySignature processedGift) manhole regift (Sewage mySignature processedGift) manhole
Just berror -> regift (Sewage mySignature (T.pack berror)) manhole Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
Nothing -> return () Nothing -> return ()

View File

@ -14,6 +14,7 @@ import Data.Hashable
import qualified Control.Monad.Parallel as Par import qualified Control.Monad.Parallel as Par
import qualified Carrion.Plugin.IO.STDIO as CPISTDIO import qualified Carrion.Plugin.IO.STDIO as CPISTDIO
import qualified Carrion.Plugin.TCL as TCLSIMP import qualified Carrion.Plugin.TCL as TCLSIMP
import qualified Carrion.Plugin.IO.IRC.Client as IRCSIMP
import Prelude hiding ((++),putStrLn,putStr) import Prelude hiding ((++),putStrLn,putStr)
import Data.Text.IO(putStrLn, putStr) import Data.Text.IO(putStrLn, putStr)
import Debug.Trace import Debug.Trace
@ -89,9 +90,9 @@ runForever s cmap iopids =
amIIO <- isIOPlugin someGarbage iopids amIIO <- isIOPlugin someGarbage iopids
if (amIIO) then if (amIIO) then
trySendToWorker s someGarbage cmap trySendToWorker s someGarbage cmap
else do else return ()
putStrLn $ T.pack theAutor ++ " sez:" putStrLn $ T.pack theAutor ++ " sez:"
putStrLn $ theSewage putStrLn $ theSewage
trySendToWorker trySendToWorker
:: TMVar Sewer -> Sewage -> TMVar CommandMap -> IO () :: TMVar Sewer -> Sewage -> TMVar CommandMap -> IO ()
@ -151,6 +152,8 @@ stdioPlugName = "STDIO haskeline"
tclPlugName :: T.Text tclPlugName :: T.Text
tclPlugName = "TCL-Simple" tclPlugName = "TCL-Simple"
ircPlugName :: T.Text
ircPlugName = "IRC-Simple"
execMain :: IO () execMain :: IO ()
execMain = do execMain = do
@ -162,6 +165,9 @@ execMain = do
tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands tryRegisterPlugin newSewer stdioPlugName CPISTDIO.initPlugin CPISTDIO.tellCommands
atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands atomically $ registerCommands commandMap stdioPlugName CPISTDIO.tellCommands
atomically $ regiop stdioPlugName iopids atomically $ regiop stdioPlugName iopids
tryRegisterPlugin newSewer ircPlugName IRCSIMP.initPlugin IRCSIMP.tellCommands
atomically $ registerCommands commandMap ircPlugName IRCSIMP.tellCommands
atomically $ regiop ircPlugName iopids
tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands tryRegisterPlugin newSewer tclPlugName TCLSIMP.initPlugin TCLSIMP.tellCommands
atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands atomically $ registerCommands commandMap tclPlugName TCLSIMP.tellCommands
let myTIDs = [] let myTIDs = []

18
src/Test-Carrion-IRC.hs Normal file
View File

@ -0,0 +1,18 @@
{-# LANGUAGE OverloadedStrings #-}
module Main
where
import Carrion.Plugin.IO.IRC.Client(initPlugin)
import GypsFulvus.PluginStuff
import Control.Concurrent.STM
import Control.Monad
import Control.Concurrent
import qualified Data.Text as T
main :: IO ()
main = do
inchan <- atomically $ newTChan
outchan <- atomically $ newTChan
let mymanhole = Manhole inchan outchan
forkIO $ initPlugin mymanhole >> return ()
forever $ do
newstuff <- atomically $ readTChan outchan
putStrLn $ "Backend " ++ (show $ getSewageAutor newstuff) ++ " returned " ++ (T.unpack $ getSewage newstuff)