{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, ScopedTypeVariables #-} module Main where import Prelude hiding (log) import Control.Concurrent import Control.Monad import Control.Monad.IO.Class import Data.List import Data.Monoid import Data.Chatty.Atoms import Data.Chatty.Counter import Data.Chatty.Hetero import Data.Chatty.None import Data.Chatty.TST import Network import Network.Anticiv.Config import Network.Anticiv.Convenience import Network.Anticiv.Masks import Network.Anticiv.Modules.Barkeeper import Network.Anticiv.Modules.Base import Network.Anticiv.Modules.Ironforge import Network.Anticiv.Modules.Mafia import Network.Anticiv.Monad import System.Chatty.Misc import System.Directory import System.Environment import System.IO import Text.Chatty.Channel.Printer import Text.Chatty.Finalizer import Text.Chatty.Printer import Text.Chatty.Scanner import Text.Chatty.Interactor import Text.Printf anticiv :: (MonadAnticiv m,ChFinalizer m,MonadIO m) => m () anticiv = cbracket Log $ do mprintLn "Initializing Anticiv." nick <- bnick mods <- bkStrL "Modules" forM_ mods $ \m -> switchTo m $ do floc <- bkStr "Localization" mloc <- readConf .<. floc case mloc of Nothing -> error $ printf "Module %s's localization cannot be read." m Just loc -> bmodify $ \b -> b{localizations=tstInsert m loc $ localizations b} s <- bkStr "Stereo" bsetStereo s lst <- runAnticiv $ Main.loadModule m bmodify $ \b -> b{moduleLister=moduleLister b++[(m,lst)]} cbracket Raw $ do mprintLn $ printf "NICK %s\r" nick mprintLn $ printf "USER %s 0 * :Igor\r" nick mflush loop loop :: (MonadIO m,MonadAnticiv m) => m () loop = do liftIO $ threadDelay 100 -- Ticks recs <- bgets tickRecipients forM_ recs $ getAtom >=> runAnticiv -- Report b <- bget t <- mgetstamp d <- bkInt "ReportTick" when (lastReport b + fromIntegral d < t) $ do bmodify $ \b -> b{lastReport=t} log $ printf "Channel Users: %i" $ length $ channelUsers b log $ printf "Priority/Emergency Chanmsg: %i/%i" (length $ priorityChanmsg b) (length $ emergencyChanmsg b) log $ printf "Priority/Emergency Querymsg: %i/%i" (length $ priorityQuerymsg b) (length $ emergencyQuerymsg b) log $ printf "Tick Recipients: %i" (length $ tickRecipients b) log $ printf "Module Stack: %s" (unwords $ moduleStack b) -- Line Processing ready <- mready when ready $ do ln <- mscanLn cprint Log ("<-- "++ln++"\r\n") n <- bnick c <- bchan void $ procln n c (init ln) loop dumpusers :: Anticiv () dumpusers = do us <- bget cprint Log "There are: " forM_ (channelUsers us) $ getAtom >=> \u -> cprint Log (show u++" ") cprint Log "\r\n" simul a b k = do a' <- a k b' <- b k return (a',b') procln :: String -> String -> String -> Anticiv Bool procln nick chan = -- React to PING requests CIString "PING" :-: RemString #-> (\s -> cprint Raw ("PONG :"++s++"\r\n")) -- Evaluate JOIN messages, add user to list .|| UserMask :-: CIToken "JOIN" :-: Remaining #-> (\(u,_) -> bmodify (\b -> b{channelUsers=channelUsers b `union` [u]}) >> dumpusers) -- Evaluate NICK messages, change user entry .|| UserMask :-: CIToken "NICK" :-: RemString #-> (\(ua,n) -> do xus <- bgets channelUsers xus' <- mapM (getAtom `Main.simul` return) xus u <- getAtom ua case filter (\(t,a) -> n `strEq` userNick t) xus' of [(u,a)] -> putAtom a $ User [] [] [] $ reauthId u case filter (\(t,a) -> userNick u `strEq` userNick t) xus' of [(u,a)] -> putAtom a $ User n [] [] $ reauthId u _ -> return ()) -- Evaluate PART messages, remove user entry -- .|| UserMask :-: Token "PART" :-: -- JOIN on MOTD end .|| ServerHost :-: Token "376" :-: Remaining #->> (cprint Raw $ printf "JOIN %s\r\n" chan) -- JOIN on MOTD missing .|| ServerHost :-: Token "422" :-: Remaining #->> (cprint Raw $ printf "JOIN %s\r\n" chan) -- Evaluate NAMES list .|| ServerHost :-: Token "353" :-: CIToken nick :-: Which [Token "=", Token "@"] :-: CIToken chan :-: RemString #-> (\(_,_,sus) -> do xus <- bgets channelUsers xus' <- mapM (getAtom `Main.simul` return) xus let elemPrefix ('@':s) = s elemPrefix ('+':s) = s elemPrefix ('&':s) = s elemPrefix ('!':s) = s elemPrefix ('%':s) = s elemPrefix s = s us <- mapM (\n -> liftM (User n [] []) $ mrandomR (1,40000)) $ map elemPrefix $ words sus let uelem us u = not $ null $ filter (strEq (userNick u) . userNick) us uinc xs [] = return xs uinc xs (x:mx) = do a <- newAtom putAtom a x uinc ((x,a):xs) mx ux <- uinc xus' $ filter (not . uelem (map fst xus')) us bmodify $ \b -> b{channelUsers=map snd ux} dumpusers) -- Send CTCP PING response .|| UserMask :-: CIToken "PRIVMSG" :-: CIToken nick :-: CIString " :\001PING " :-: Remaining #-> (\(u,st) -> notice u ("\001PING "++st)) -- Send CTCP LIST response .|| UserMask :-: CIToken "PRIVMSG" :-: CIToken nick :-: CIString " :\001LIST\001" :-: Remaining #-> (\(u,_) -> do lsts <- bgets moduleLister forM_ lsts $ \(m,l) -> do notice u ("--- %"++m++" ---") pref <- switchTo m bprefix ls <- runAnticiv l li <- ulang u forM ls $ \c -> switchTo m $ do c' <- bvStr li ("Commands/"++c) noticefl u ("Commands/Descriptions/"++c) c' :: Anticiv ()) -- Dispatch channel PRIVMSG to handlers .|| UserMask :-: CIToken "PRIVMSG" :-: CIToken chan :-: RemString #-> (\(u,msg) -> do let msg' | "\001ACTION" `isPrefixOf` msg = "ME "++(init $ drop 8 msg) | otherwise = msg pas <- bgets priorityChanmsg phs <- mapM getAtom pas eas <- bgets emergencyChanmsg ehs <- mapM getAtom eas foldr (#||) (return False) $ map (\f -> runAnticiv $ f u msg') (phs ++ ehs) return ()) -- Dispatch query PRIVMSG to handlers .|| UserMask :-: CIToken "PRIVMSG" :-: CIToken nick :-: RemString #-> (\(u,msg) -> do let msg' | "\001ACTION" `isPrefixOf` msg = "ME "++(init $ drop 8 msg) | otherwise = msg pas <- bgets priorityQuerymsg phs <- mapM getAtom pas eas <- bgets emergencyQuerymsg ehs <- mapM getAtom eas let fallback = private u "Sorry, I can't understand you." >> return False foldr (#||) fallback $ map (\f -> runAnticiv $ f u msg') (phs ++ ehs) return ()) main = void $ withLazyIO $ flip runCounterT 0 $ flip runAtomStoreT none $ do args <- liftIO $ getArgs conf <- readConf .<. if null args then "anticiv.conf" else args !! 0 case conf of Nothing -> error "Config cannot be found or is unintellegible." Just conf -> let initialBotState = BotState none none none none none none none conf ["%"] none none none none none (fromIntegral 0) (fromIntegral 0) in flip runBotT initialBotState $ do server <- bkStr "Connection/Server" port <- bkInt "Connection/Port" chan <- bkStr "Connection/Channel" nick <- bkStr "Connection/Nick" h <- liftIO $ connectTo server (PortNumber (fromIntegral port)) mqfh h liftIO $ hSetBuffering h NoBuffering bkStr "LinguaInitii" >>= bmodify . \l b -> b{botLingua=l} runOutPlex anticiv h [Raw] .<. h loadModule :: String -> Packciv (Packciv [String]) loadModule "Base" = initBase loadModule "Barkeeper" = initBarkeeper loadModule "Mafia" = initMafia loadModule "Ironforge" = initIronforge loadModule _ = return $ return none