module Network.FastIRC.Session
(
Bot,
BotCommand(..),
BotInfo(..),
BotSession,
Event(..),
EventHandler,
Params(..),
ircSendCmd,
ircSendMsg,
ircSendString,
onEvent,
sendBotCmd,
startBot,
onConnect,
onDisconnect,
onError,
onLoggedIn,
onMessage,
onQuit,
getBotInfo
)
where
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Control.Applicative
import Control.Concurrent
import Data.Map (Map)
import Data.Unique
import MonadLib
import Network.Fancy
import Network.FastIRC.IO
import Network.FastIRC.Messages
import Network.FastIRC.ServerSet
import Network.FastIRC.Types
import System.IO
type Bot = ContT () (StateT Config (ReaderT Params IO))
data BotCommand
= BotAddHandler (EventHandler -> IO ()) (Event -> Bot ())
| BotDispatch Event
| BotError String
| BotQuit (Maybe CommandArg)
| BotRecv Message
| BotSendCmd Command
| BotSendMsg Message
| BotSendString MsgString
| BotTerminate
data BotInfo =
BotInfo {
botCurrentNick :: Maybe NickName
}
data BotSession =
BotSession {
botCmdChan :: Chan BotCommand
}
data Config =
Config {
botEventHandlers :: Map EventHandler (Event -> Bot ()),
botEventChan :: Chan Event,
botHandle :: Handle,
botInfo :: BotInfo,
botIsQuitting :: Bool,
botKillerThread :: Maybe ThreadId,
botServers :: ServerSet,
botSession :: BotSession
}
data Event
= ConnectedEvent
| DisconnectedEvent
| ErrorEvent String
| LoggedInEvent
| MessageEvent Message
| QuitEvent
deriving (Eq, Read, Show)
type EventHandler = Unique
data Params =
Params {
botGetNick :: IO NickName,
botGetUser :: IO UserName,
botGetRealName :: IO RealName,
botPassword :: Maybe CommandArg,
botServerAddr :: Address
}
botManager :: Params -> Config -> IO ()
botManager params cfg = do
let eventChan = botEventChan $ cfg
cmdChan = botCmdChan . botSession $ cfg
h = botHandle $ cfg
writeChan eventChan ConnectedEvent
dispatchThread <- forkIO $
getChanContents eventChan >>= writeList2Chan cmdChan . map BotDispatch
netThread <- forkIO $ networkHandler cmdChan (botHandle cfg)
runBot params cfg $ do
sendLogin
forever $ do
bcmd <- inBase $ readChan cmdChan
case bcmd of
BotAddHandler reportId f -> do
hid <- inBase newUnique
handlers <- botEventHandlers <$> get
sets_ (\cfg -> cfg { botEventHandlers = M.insert hid f handlers })
inBase $ reportId hid
BotDispatch ev -> do
handlerList <- M.elems . botEventHandlers <$> get
mapM_ ($ ev) handlerList
BotError err -> do
isQuitting <- botIsQuitting <$> get
unless isQuitting . inBase . writeChan eventChan $ ErrorEvent err
die
BotQuit reason -> do
inBase $ hPutCommand h (QuitCmd reason)
ktid <- inBase . forkIO $
threadDelay 1000000 >>
writeChan cmdChan BotTerminate
sets_ $ \cfg -> cfg { botIsQuitting = True,
botKillerThread = Just ktid }
BotRecv msg ->
inBase (writeChan eventChan $ MessageEvent msg) >>
handleMsg msg
BotSendCmd cmd -> inBase $ hPutCommand h cmd
BotSendMsg msg -> inBase $ hPutMessage h msg
BotSendString str -> inBase $ B.hPutStr h str
BotTerminate -> die
killThread dispatchThread
killThread netThread
where
networkHandler :: Chan BotCommand -> Handle -> IO ()
networkHandler cmdChan h = do
res <- try $ hGetMessage h
case res of
Left err -> writeChan cmdChan $ BotError (show err)
Right msg ->
writeChan cmdChan (BotRecv msg) >>
networkHandler cmdChan h
die :: Bot ()
die = do
isQuitting <- botIsQuitting <$> get
ktidM <- botKillerThread <$> get
handlerList <- M.elems . botEventHandlers <$> get
when isQuitting $ mapM_ ($ QuitEvent) handlerList
case ktidM of
Just ktid -> inBase $ killThread ktid
Nothing -> return ()
mapM_ ($ DisconnectedEvent) handlerList
abort ()
defBotInfo :: BotInfo
defBotInfo =
BotInfo { botCurrentNick = Nothing }
handleMsg :: Message -> Bot ()
handleMsg msg = do
h <- botHandle <$> get
let origin = msgOrigin msg
cmd = msgCommand msg
eventChan <- botEventChan <$> get
case cmd of
NumericCmd 1 (myNick:_) -> do
inBase $ writeChan eventChan LoggedInEvent
sets_ $ \cfg -> let bi = (botInfo cfg) { botCurrentNick = Just myNick }
in cfg { botInfo = bi }
PingCmd a b -> inBase $ hPutCommand h (PongCmd a b)
_ -> return ()
ircSendCmd :: BotSession -> Command -> IO ()
ircSendCmd bs = sendBotCmd bs . BotSendCmd
ircSendMsg :: BotSession -> Message -> IO ()
ircSendMsg bs = sendBotCmd bs . BotSendMsg
ircSendString :: BotSession -> MsgString -> IO ()
ircSendString bs = sendBotCmd bs . BotSendString
onEvent :: BotSession -> (Event -> Bot ()) -> IO EventHandler
onEvent bs f = do
let cmdChan = botCmdChan bs
answerVar <- newEmptyMVar
writeChan cmdChan $ BotAddHandler (putMVar answerVar) f
takeMVar answerVar
runBot :: Params -> Config -> Bot () -> IO ()
runBot params cfg =
fmap fst .
runReaderT params .
runStateT cfg .
runContT return
sendBotCmd :: BotSession -> BotCommand -> IO ()
sendBotCmd bs cmd = writeChan (botCmdChan bs) cmd
sendLogin :: Bot ()
sendLogin = do
h <- botHandle <$> get
nick <- asks botGetNick >>= inBase
user <- asks botGetUser >>= inBase
real <- asks botGetRealName >>= inBase
addr <- asks botServerAddr
pass <- asks botPassword
let (host, port) =
case addr of
IP h p -> (B.pack h, B.pack $ show p)
IPv4 h p -> (B.pack h, B.pack $ show p)
IPv6 h p -> (B.pack h, B.pack $ show p)
_ -> ("localhost", "6667")
inBase $ do
case pass of
Just pwd -> hPutCommand h $ PassCmd pwd
Nothing -> return ()
hPutCommand h $ NickCmd nick Nothing
hPutCommand h $ UserCmd user host port real
startBot :: Params -> IO (Either IOError BotSession)
startBot params = do
cmdChan <- newChan
eventChan <- newChan
errorVar <- newEmptyMVar
let session = BotSession { botCmdChan = cmdChan }
forkIO $
let comp =
withStream (botServerAddr params) $ \h ->
let cfg =
Config {
botEventHandlers = M.empty,
botEventChan = eventChan,
botHandle = h,
botInfo = defBotInfo,
botIsQuitting = False,
botKillerThread = Nothing,
botServers = emptyServers,
botSession = session
}
in do
hSetBuffering h NoBuffering
putMVar errorVar Nothing
res <- try $ botManager params cfg
case res of
Left err -> do
hPutStrLn stderr "Warning (fastirc): unexpected exception:"
hPrint stderr err
hPutStrLn stderr "Please report this to the author."
Right _ -> return ()
in comp `catch` (putMVar errorVar . Just)
error <- takeMVar errorVar
case error of
Nothing -> return (Right session)
Just err -> return (Left err)
onConnect :: BotSession -> Bot () -> IO EventHandler
onConnect bs c = onEvent bs $ \ev -> case ev of ConnectedEvent -> c; _ -> return ()
onDisconnect :: BotSession -> Bot () -> IO EventHandler
onDisconnect bs c = onEvent bs $ \ev -> case ev of DisconnectedEvent -> c; _ -> return ()
onError :: BotSession -> (String -> Bot ()) -> IO EventHandler
onError bs f = onEvent bs $ \ev -> case ev of ErrorEvent str -> f str; _ -> return ()
onLoggedIn :: BotSession -> Bot () -> IO EventHandler
onLoggedIn bs c = onEvent bs $ \ev -> case ev of LoggedInEvent -> c; _ -> return ()
onMessage :: BotSession -> (Message -> Bot ()) -> IO EventHandler
onMessage bs f = onEvent bs $ \ev -> case ev of MessageEvent msg -> f msg; _ -> return ()
onQuit :: BotSession -> Bot () -> IO EventHandler
onQuit bs c = onEvent bs $ \ev -> case ev of QuitEvent -> c; _ -> return ()
getBotInfo :: Bot BotInfo
getBotInfo = botInfo <$> get