add irc, add more handlers
This commit is contained in:
parent
5342dafe3f
commit
6edb35727f
@ -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,
|
||||||
|
157
src/Carrion/Plugin/IO/IRC/Client.hs
Normal file
157
src/Carrion/Plugin/IO/IRC/Client.hs
Normal 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
|
@ -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 ()
|
||||||
|
@ -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,7 +90,7 @@ 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
|
||||||
|
|
||||||
@ -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
18
src/Test-Carrion-IRC.hs
Normal 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)
|
Loading…
x
Reference in New Issue
Block a user