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
|
module Hsbot.Core
( initHsbot
, runHsbot
, terminateHsbot
) where
import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Network
import qualified Network.IRC as IRC
import Network.BSD (getHostName)
import Network.TLS
import Prelude hiding (catch)
import System.IO
import System.Log.Logger
import Hsbot.Plugin
import Hsbot.Types
import Hsbot.Utils
initHsbot :: Config -> IO (BotEnv)
initHsbot config = do
chan <- newChan :: IO (Chan Message)
threadIdsMv <- newMVar []
quitMv <- newEmptyMVar
let hostname = configAddress config
port = configPort config
infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
connhdl <- connectTo hostname port
hSetBuffering connhdl LineBuffering
hSetEncoding connhdl utf8
(tls, tlsCtx) <- case sslOn $ configTLS config of
True -> do
infoM "Hsbot.Core" "TLS init"
tlsenv <- initTLSEnv (configTLS config)
randomGen <- makeSRandomGen >>= either (fail . show) (return . id)
sCtx <- client tlsenv randomGen connhdl
handshake sCtx
return (Just tlsenv, Just sCtx)
False -> return (Nothing, Nothing)
return BotEnv { envHandle = connhdl
, envChan = chan
, envQuitMv = quitMv
, envThreadIdsMv = threadIdsMv
, envConfig = config
, envTLS = tls
, envTLSCtx = tlsCtx }
runHsbot :: Env IO (BotStatus)
runHsbot = do
let bot = BotState { botPlugins = M.empty
, botHooks = []
, botChannels = []
, botNickname = [] }
evalStateT trueRunHsbot bot
where
trueRunHsbot :: Bot (Env IO) (BotStatus)
trueRunHsbot = do
-- First we say hello
env <- lift ask
hostname <- liftIO getHostName
let connhdl = envHandle env
tlsCtx = envTLSCtx env
config = envConfig env
nickname = head $ configNicknames config
channels = configChannels config
liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.nick nickname
liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-- Next we spawn the reader thread
liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
myOwnThreadId <- liftIO $ myThreadId
chan <- lift $ asks envChan
(liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar
-- Then we spawn all plugins
(lift $ asks envConfig) >>= mapM_ loadPlugin . configPlugins
-- Finally we spawn the main bot loop
bot <- get
finalStateMVar <- liftIO newEmptyMVar
(liftIO . forkIO $ runReaderT (execStateT botLoop bot >>= storeFinalState finalStateMVar) env) >>= lift . addThreadIdToQuitMVar
-- We wait for the quit signal
code <- asks envQuitMv >>= liftIO . takeMVar
-- and we clean things up
asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
-- TODO : kill plugin threads
return code
storeFinalState :: MVar BotState -> BotState -> Env IO ()
storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
botReader _ (Just ctx) chan _ = forever $
recvData ctx >>= return . L.toChunks >>= mapM_ (handleIncomingStr chan . C.unpack) -- TODO exceptions
botReader handle Nothing chan fatherThreadId = forever $
(hGetLine handle) `catch` handleIOException >>= handleIncomingStr chan
where
handleIOException :: IOException -> IO (String)
handleIOException ioException = do
throwTo fatherThreadId ioException
myId <- myThreadId
killThread myId
return ""
handleIncomingStr :: Chan Message -> String -> IO ()
handleIncomingStr chan str = do
case IRC.decode str of
Just msg -> do
debugM "Ircd.Reader" $ "<-- " ++ (show msg)
writeChan chan $ IncomingMsg msg
Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control
botLoop :: Bot (Env IO) ()
botLoop = forever $ do
chan <- lift $ asks envChan
hooks <- gets botHooks
msg <- liftIO $ readChan chan
mapM_ (liftIO . flip writeChan msg) hooks
case msg of
IncomingMsg _ -> return () -- TODO parse for core commands
OutgoingMsg outMsg -> do
env <- lift ask
let connhdl = envHandle env
tlsCtx = envTLSCtx env
liftIO $ debugM "Ircd.Reader" $ "--> " ++ (show outMsg)
liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
terminateHsbot :: Env IO ()
terminateHsbot = do
liftIO $ infoM "Hsbot.Core" "Closing connection"
asks envHandle >>= liftIO . hClose
|
