anticiv-0.1.0.4: Main.hs
{-# 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