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
|
module Hsbot.Core
( initHsbot
, runHsbot
, terminateHsbot
) where
import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
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.Config
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
-- First we say hello
env <- ask
hostname <- liftIO getHostName
let connhdl = envHandle env
tlsCtx = envTLSCtx env
config = envConfig env
nickname = head $ configNicknames config
channels = configChannels config
liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.nick nickname
liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
mapM_ (liftIO . sendStrToClient connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-- Next we spawn the reader thread
liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
myOwnThreadId <- liftIO $ myThreadId
chan <- asks envChan
(liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
-- Then we spawn all plugins
-- asks envSocket >>= mapM_ ( ----- what's next? the core server handling! ----- )
-- Finally we spawn the main bot loop
--
-- We wait for the quit signal
code <- asks envQuitMv >>= liftIO . takeMVar
-- and we clean things up
asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
return code
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
terminateHsbot :: Env IO ()
terminateHsbot = do
liftIO $ infoM "Hsbot.Core" "Closing connection"
asks envHandle >>= liftIO . hClose
|
