1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
module Hsbot.Irc.Core
( startIrcbot
) where
import Control.Concurrent
import Control.Exception (AsyncException, Handler (..), IOException, catch, catches)
import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Network
import Prelude hiding (catch)
import System.IO
import Hsbot.Irc.CLI
import Hsbot.Irc.Command
import Hsbot.Irc.Config
import Hsbot.Irc.Message
import Hsbot.Irc.Plugin
import Hsbot.Irc.Server
import Hsbot.Irc.Types
-- | IrcBot's main entry point
startIrcbot :: Options -> IrcConfig -> IO ()
startIrcbot opts ircConfig = do
when (optDebug opts) $ putStrLn "[IrcBot] Opening communication channel... "
chan <- newChan :: IO (Chan IrcBotMsg)
when (optDebug opts) . putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress ircConfig, "... "]
handle <- connectTo (ircConfigAddress ircConfig) (ircConfigPort ircConfig)
hSetBuffering handle NoBuffering
hSetEncoding handle utf8
when (optDebug opts) $ putStrLn "[IrcBot] Spawning reader thread..."
myOwnThreadId <- myThreadId
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
when (optDebug opts) $ putStrLn "[IrcBot] Initializing server connection..."
let ircServerState = IrcServerState { ircServerId = ircConfigAddress ircConfig
, ircServerChannels = []
, ircServerNickname = ircConfigNickname ircConfig
, ircServerCommandPrefix = ircConfigCommandPrefix ircConfig
, ircServerChan = chan }
ircBotState = IrcBotState { ircBotPlugins = M.empty
, ircBotCommands = M.empty
, ircBotChan = chan
, ircBotServerState = ircServerState
, ircBotHandle = handle
, ircBotConfig = ircConfig }
ircBotState' <- execStateT (initBotServerConnection ircConfig) ircBotState
when (optDebug opts) $ putStrLn "[IrcBot] Spawning plugins..."
ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
when (optDebug opts) $ putStrLn "[IrcBot] Entering Core loop... "
(_, ircBotState''') <- runLoop ircBotState''
when (optDebug opts) $ putStrLn "[IrcBot] Killing reader thread..."
killThread readerThreadId
when (optDebug opts) $ putStrLn "[IrcBot] Killing active plugins... "
evalStateT (mapM_ killIrcPlugin . M.keys $ ircBotPlugins ircBotState''') ircBotState'''
where
runLoop :: IrcBotState -> IO (BotStatus, IrcBotState)
runLoop botState = do
(status, botState') <- (runStateT ircBotCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
, Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
case status of
BotContinue -> runLoop botState'
_ -> return (status, botState')
-- | Runs the IrcBot's reader loop
ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
ircBotReader handle chan fatherThreadId = forever $ do
str <- (hGetLine handle) `catch` handleIOException
let msg = parseIrcMsg str
case msg of
Right msg' -> writeChan chan (InIrcMsg msg')
_ -> return ()
where
handleIOException :: IOException -> IO (String)
handleIOException ioException = do
throwTo fatherThreadId ioException
myId <- myThreadId
killThread myId
return ""
-- | Initialize the bot's server connection
initBotServerConnection :: IrcConfig -> IrcBot ()
initBotServerConnection config = do
ircBot <- get
let ircServerState = ircBotServerState ircBot
ircServerState' <- execStateT (initServerConnection config) ircServerState
put $ ircBot { ircBotServerState = ircServerState' }
-- | Run the IrcBot's main loop
ircBotCore :: IrcBot (BotStatus)
ircBotCore = do
chan <- gets ircBotChan
msg <- liftIO $ readChan chan
case msg of
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
IntIrcCmd intIrcCmd -> processInternalCommand $ IntIrcCmd intIrcCmd
where
sendThisMessage :: IrcMsg -> IrcBot (BotStatus)
sendThisMessage outputMsg = do
let str = serializeIrcMsg outputMsg
handle <- gets ircBotHandle
liftIO $ hPutStr handle (str ++ "\r\n")
return BotContinue
-- | Dispatches an input message
dispatchMessage :: IrcBotMsg -> IrcBot (BotStatus)
dispatchMessage (InIrcMsg inIrcMsg) = do
config <- gets ircBotConfig
plugins <- gets ircBotPlugins
cmds <- gets ircBotCommands
if (isPluginCommand config)
then
let key = tail . head $ words getMsgContent
pluginNames = fromMaybe [] $ M.lookup key cmds
plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins'
else
mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins)
return BotContinue
where
isPluginCommand :: IrcConfig -> Bool
isPluginCommand config =
and [ ircMsgCommand inIrcMsg == "PRIVMSG"
, (head getMsgContent) == ircConfigCommandPrefix config ]
sendRunCommand :: String -> IrcPluginState -> IrcBot ()
sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
getMsgContent :: String
getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
dispatchMessage _ = return (BotContinue)
|
