module Network.Anticiv.Monad where
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Monoid
import Data.Time.Clock
import Data.Typeable
import Game.Antisplice.Monad
import Game.Antisplice.Templates
import Data.Chatty.Atoms
import Data.Chatty.Counter
import Data.Chatty.AVL
import Data.Chatty.Hetero
import Data.Chatty.TST
import Network.Anticiv.Config
import System.Chatty.Misc
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.Chatty.Interactor.Templates
import Text.Printf
newtype BotT m a = BotT { runBotT :: BotState -> m (a,BotState) }
instance Functor f => Functor (BotT f) where
fmap f (BotT a) = BotT $ \s -> fmap (first f) $ a s
instance (Functor f, Monad f) => Applicative (BotT f) where
pure = return
fm <*> fa = do
f <- fm
a <- fa
return (f a)
instance Monad m => Monad (BotT m) where
return a = BotT $ \s -> return (a,s)
m >>= f = BotT $ \s -> do (a,s') <- runBotT m s; runBotT (f a) s'
instance MonadTrans BotT where
lift m = BotT $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (BotT m) where
liftIO = lift . liftIO
data User = User {
userNick :: String,
userName :: String,
userHost :: String,
reauthId :: Int
} deriving Eq
type UserA = Atom User
instance Show User where
show (User ni "" "" _) = ni
show (User ni na ho _) = printf "%s!%s@%s" ni na ho
instance Tuplify User User where
tuplify = id
instance Tuplify (Atom a) (Atom a) where
tuplify = id
data BotState = BotState {
channelUsers :: [UserA],
orphanedUsers :: [UserA],
priorityChanmsg :: [HandlerA],
emergencyChanmsg :: [HandlerA],
priorityQuerymsg :: [HandlerA],
emergencyQuerymsg :: [HandlerA],
tickRecipients :: [AnticivA ()],
botConfig :: Config,
moduleStack :: [String],
localizations :: TST Config,
botLingua :: String,
linguaOverride :: AVL (UserA, String),
moduleStereo :: TST String,
moduleLister :: [(String,Packciv [String])],
lastMsg :: NominalDiffTime,
lastReport :: NominalDiffTime
}
type MonadAnticiv m = (Functor m, Monad m, ChPrinter m, ChScanner m, ChClock m, ChChannelPrinter Target m, MonadBot m, ChAtoms m,ChRandom m)
type Anticiv a = forall m. MonadAnticiv m => m a
newtype Packciv a = Anticiv { runAnticiv :: Anticiv a }
type AnticivA a = Atom (Packciv a)
instance Monad Packciv where
return a = Anticiv $ return a
m >>= f = Anticiv $ runAnticiv m >>= runAnticiv . f
instance Functor Packciv where
fmap f a = liftM f a
class Monad m => MonadBot m where
bget :: m BotState
bput :: BotState -> m ()
instance Monad m => MonadBot (BotT m) where
bget = BotT $ \s -> return (s,s)
bput s = BotT $ \_ -> return ((),s)
bmodify :: MonadBot m => (BotState -> BotState) -> m ()
bmodify f = bgets f >>= bput
bgets :: MonadBot m => (BotState -> a) -> m a
bgets f = f `liftM` bget
sleep :: ChClock m => Int -> m ()
sleep ms = do
a <- mgetstamp
let loop = do
b <- mgetstamp
if a + fromRational (fromIntegral ms/1000) > b
then loop
else return ()
loop
type Handler = UserA -> String -> Packciv Bool
type HandlerA = Atom Handler
data Target = Log | Target String | Notice String | Address User | Raw deriving Eq
newtype OutPlexT m a = OutPlex { runOutPlex :: Handle -> [Target] -> m (a,[Target]) }
instance Functor f => Functor (OutPlexT f) where
fmap f a = OutPlex $ \h ts -> fmap (first f) $ runOutPlex a h ts
instance (Functor f, Monad f) => Applicative (OutPlexT f) where
pure = return
fm <*> fa = do
f <- fm
a <- fa
return (f a)
instance Monad m => Monad (OutPlexT m) where
return a = OutPlex $ \h ts -> return (a,ts)
m >>= f = OutPlex $ \h ts -> do
(a,ts') <- runOutPlex m h ts
runOutPlex (f a) h ts'
instance MonadTrans OutPlexT where
lift m = OutPlex $ \h ts -> do a <- m; return (a,ts)
instance MonadIO m => MonadIO (OutPlexT m) where
liftIO = lift . liftIO
instance (MonadIO m,ChPrinter m,MonadBot m,ChClock m,ChAtoms m) => ChPrinter (OutPlexT m) where
mprint s = OutPlex $ \h ts -> do
unless (head ts == Log) $ do
t <- bgets lastMsg
tw <- bkInt "Throttle"
let wait = do
t' <- mgetstamp
if t' > t+(fromRational (fromIntegral tw / 1000))
then return ()
else wait
wait
t' <- mgetstamp
bmodify $ \b -> b{lastMsg=t'}
case head ts of
Log -> do
m <- bmodule
mprint ("["++m++"] "++s)
Raw -> liftIO $ hPutStr h s
Target ch -> liftIO $ hPrintf h "PRIVMSG %s :%s" ch s
Address de -> do
ch <- bkStr "Connection/Channel"
liftIO $ hPrintf h "PRIVMSG %s :%s: %s" ch (userNick de) s
Notice ch -> liftIO $ hPrintf h "NOTICE %s :%s" ch s
return ((),ts)
mflush = OutPlex $ \h ts -> (case head ts of
Log -> mflush
_ -> liftIO $ hFlush h ) >> return ((),ts)
instance (MonadIO m,ChPrinter m,MonadBot m,ChClock m,ChAtoms m) => ChChannelPrinter Target (OutPlexT m) where
cstart c = OutPlex $ \_ ts -> return ((),c:ts)
cfin _ = OutPlex $ \_ ts -> return ((),tail ts)
cthis = OutPlex $ \_ ts -> return (head ts,ts)
instance MonadBot m => MonadBot (OutPlexT m) where
bget = lift bget
bput = lift . bput
instance MonadBot m => MonadBot (OutRedirT m) where
bget = lift bget
bput = lift . bput
instance MonadBot m => MonadBot (InRedirT m) where
bget = lift bget
bput = lift . bput
bkInt :: (MonadBot m,ChAtoms m) => String -> m Int
bkInt s = do
c <- bgets botConfig
m <- bmodule
case mgetKey m s c of
Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
Just (TempLeaf (IntValT i)) -> return i
Just (RefLeaf (IntVal a)) -> getAtom a
_ -> error $ printf "Key %s has the wrong type. Check your config file." s
bkStr :: (MonadBot m,ChAtoms m) => String -> m String
bkStr s = do
c <- bgets botConfig
m <- bmodule
case mgetKey m s c of
Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
Just (TempLeaf (StrValT i)) -> return i
Just (RefLeaf (StrVal a)) -> getAtom a
_ -> error $ printf "Key %s has the wrong type. Check your config file." s
bkStrL :: (MonadBot m,ChAtoms m) => String -> m [String]
bkStrL s = do
c <- bgets botConfig
m <- bmodule
case mgetKey m s c of
Nothing -> error $ printf "Could not find essential key %s. Check your config file." s
Just (TempLeaf (StrListT i)) -> return i
Just (RefLeaf (StrList a)) -> getAtom a
_ -> error $ printf "Key %s has the wrong type. Check your config file." s
bmodule :: MonadBot m => m String
bmodule = bgets $ head . moduleStack
bstereo :: MonadBot m => m String
bstereo = do
m <- bmodule
ms <- bgets moduleStereo
return $ case tstLookup m ms of
Just s -> s
Nothing -> []
mkInteractor ''BotT mkPrinter mkScanner mkFinalizer mkRandom mkClock mkAtoms mkCounter
mkInteractor ''OutPlexT mkScanner mkFinalizer mkRandom mkClock mkAtoms mkCounter
instance ChPrinter Packciv where
mprint s = Anticiv $ mprint s
mnoecho s = Anticiv $ mnoecho s
mflush = Anticiv mflush
mnomask s = Anticiv $ mnomask s
instance ChScanner Packciv where
mscan1 = Anticiv mscan1
mscanL = Anticiv mscanL
mscannable = Anticiv mscannable
mscanh = Anticiv mscanh
mready = Anticiv mready
instance ChClock Packciv where
mutctime = Anticiv mutctime
mgetstamp = Anticiv mgetstamp
instance ChChannelPrinter Target Packciv where
cstart c = Anticiv $ cstart c
cfin c = Anticiv $ cfin c
cprint c s = Anticiv $ cprint c s
cthis = Anticiv cthis
instance ChAtoms Packciv where
newAtom = Anticiv newAtom
putAtom a v = Anticiv $ putAtom a v
getAtom a = Anticiv $ getAtom a
dispAtom a = Anticiv $ dispAtom a
cloneAtom a = Anticiv $ cloneAtom a
instance ChCounter Packciv where
countOn = Anticiv countOn
instance ChRandom Packciv where
mrandom = Anticiv mrandom
mrandomR r = Anticiv $ mrandomR r
instance MonadBot Packciv where
bget = Anticiv bget
bput s = Anticiv $ bput s