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
131
132
133
134
135
136
137
138
139
140
141
142
|
module Hsbot.Irc.Core
( ircbot
) where
import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Time
import Network
import Prelude hiding (catch)
import System.IO
import Hsbot.Irc.Command
import Hsbot.Irc.Config
import Hsbot.Irc.Message
import Hsbot.Irc.Plugin
import Hsbot.Irc.Server
import Hsbot.Irc.Types
import Hsbot.Message (BotMsg)
-- | IrcBot's main entry point
ircbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO ()
ircbot config masterChan myChan = do
startTime <- getCurrentTime
putStrLn "[IrcBot] Opening communication channel... "
chan <- newChan :: IO (Chan IrcBotMsg)
putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "]
handle <- connectTo (ircConfigAddress config) (ircConfigPort config)
hSetBuffering handle NoBuffering
myOwnThreadId <- myThreadId
putStrLn "[IrcBot] Spawning reader threads..."
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan
putStrLn "[IrcBot] Initializing server connection..."
let ircServerState = IrcServerState { ircServerId = ircConfigAddress config
, ircServerChannels = []
, ircServerNickname = ircConfigNickname config
, ircServerCommandPrefix = ircConfigCommandPrefix config
, ircServerChan = chan }
ircBotState = IrcBotState { ircBotStartTime = startTime
, ircBotPlugins = M.empty
, ircBotCommands = M.empty
, ircBotChan = chan
, ircBotMasterChan = masterChan
, ircBotMyChan = myChan
, ircBotServerState = ircServerState
, ircBotHandle = handle
, ircBotConfig = config
, ircBotReaderThreadId = readerThreadId
, ircBotMasterReaderThreadId = masterReaderThreadId }
ircBotState' <- execStateT (initBotServerConnection config) ircBotState
putStrLn "[IrcBot] Entering main loop... "
_ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ())
return ()
-- | 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 ""
-- | Reads the Master's chan
ircBotMasterReader :: Chan BotMsg -> Chan IrcBotMsg -> IO ()
ircBotMasterReader masterChan _ = forever $ do
_ <- readChan masterChan
return ()
-- TODO : handle botMsg
-- | 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' }
-- | IrcBot's loop that can catch ircbot's states' updates
ircBotLoop :: IrcBotState -> IO ()
ircBotLoop ircBotState = do
putStrLn "[IrcBot] Spawning plugins..."
ircBotState' <- execStateT spawnIrcPlugins ircBotState
-- Todo : throw new ircbotstate to hsbot
putStrLn "[IrcBot] Entering Core loop... "
_ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState')
return ()
-- TODO : loop!
-- | Run the IrcBot's main loop
ircBotCore :: IrcBot ()
ircBotCore = forever $ do
ircBot <- get
let chan = ircBotChan ircBot
msg <- liftIO $ readChan chan
case msg of
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
IntIrcCmd intIrcCmd -> do
processInternalCommand $ IntIrcCmd intIrcCmd
where
sendThisMessage :: IrcMsg -> IrcBot ()
sendThisMessage outputMsg = do
let str = serializeIrcMsg outputMsg
handle <- gets ircBotHandle
liftIO $ hPutStr handle (str ++ "\r\n")
-- | Dispatches an input message
dispatchMessage :: IrcBotMsg -> IrcBot ()
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) plugins'
else
mapM_ (sendToPlugin $ InIrcMsg inIrcMsg) (M.elems plugins)
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 ()
|
