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
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:
default-language: Haskell2010
hs-source-dirs: src
@ -27,7 +27,17 @@ library
hashable,
monad-parallel,
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
Includes: /usr/include/tcl.h,
src/tclstubswrapper/tclstubs.h
@ -49,14 +59,24 @@ executable GypsFulvus
hashable,
monad-parallel,
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:
-O2
-threaded
-with-rtsopts=-N
-g
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
extra-libraries: tcl8.6
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 wi s = do
processCommand :: TCLInterpreterWrapper -> Sewage -> Bool -> IO T.Text
processCommand wi s ip = do
let tcl_EvalEx = getEvalEx wi
tcl_GetStringResult = getGetStringResult 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
_ -> errorInfo >> tcl_GetStringResult interp >>= peekCString
performFromIRC = doTheTCL $ "pub:tcl:perform \"" ++ sewNick ++ "\" \"" ++ sewMask ++ "\" {} \"" ++ sewChan ++ "\" {" ++ sewCmd ++ "}"
performAdminLevel = doTheTCL sewCmd
-- harvester <- forkIO $ do
-- threadDelay 15000000
-- putStrLn "cancelling thread!!!"
@ -157,7 +158,7 @@ processCommand wi s = do
-- putStrLn $ "cancel status " ++ (show fff)
-- hngggg <- tcl_AsyncInvoke interp 0
-- putStrLn $ "asyncinvoke returned " ++ (show hngggg)
res <- performFromIRC
res <- if (ip) then performAdminLevel else performFromIRC
-- putStrLn "putting back the interp"
atomically $ putTMVar i interp
return $ T.pack res
@ -174,7 +175,8 @@ rEPL wrappedtclinterp manhole =
let hmm = gnarlyBalanced $ T.unpack cmdBodyStripped
case hmm of
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
Just berror -> regift (Sewage mySignature (T.pack berror)) manhole
Nothing -> return ()

View File

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