add irc, add more handlers

GypsFulvus.cabal

@@ -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,

src/Carrion/Plugin/IO/IRC/Client.hs

@@ -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

src/Carrion/Plugin/TCL.hs

@@ -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
       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 ()

src/GypsFulvus.hs

@@ -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,7 +90,7 @@ runForever s cmap iopids =
        amIIO <- isIOPlugin someGarbage iopids
        if (amIIO) then
          trySendToWorker s someGarbage cmap
-       else do
+       else return ()
        putStrLn $ T.pack theAutor ++ " sez:"
        putStrLn $ theSewage
 
@@ -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  = []

src/Test-Carrion-IRC.hs

@@ -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)