add irc, add more handlers
This commit is contained in:
Jon Doe
Maciej Bonin
parent
5342dafe3f
commit
6edb35727f
@ -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,
|
||||
|
||||
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 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 ()
|
||||
|
||||
@ -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
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