summaryrefslogtreecommitdiff
path: root/Hsbot/Core.hs
blob: 4dc1e9219da2904d6da0b0a00cceb8ccdc661e94 (plain)
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
143
144
145
146
module Hsbot.Core
    ( initHsbot
    , runHsbot
    , terminateHsbot
    ) where

import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.Reader
import Crypto.Random
import qualified Data.ByteString.Lazy.UTF8 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)
    botState <- newEmptyMVar
    threadIdsMv <- newMVar []
    quitMv <- newEmptyMVar
    let hostname = configAddress config
        port = configPort config
    infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
    connhdl <- connectTo hostname port
    hSetBuffering connhdl NoBuffering
    hSetEncoding connhdl utf8
    (tls, tlsCtx) <- if sslOn $ configTLS config
        then (do
            infoM "Hsbot.Core" "Initializing TLS communication"
            tlsenv <- initTLSEnv (configTLS config)
            randomGen <- newGenIO :: IO SystemRandom
            sCtx <- client tlsenv randomGen connhdl
            success <- handshake sCtx
            unless success $ errorM "Hsbot.Core" "TLS handshake failed"  -- TODO: do some usefull error handling
            return (Just tlsenv, Just sCtx))
        else return (Nothing, Nothing)
    return BotEnv { envBotState    = botState
                  , envHandle      = connhdl
                  , envChan        = chan
                  , envQuitMv      = quitMv
                  , envThreadIdsMv = threadIdsMv
                  , envConfig      = config
                  , envTLS         = tls
                  , envTLSCtx      = tlsCtx }

runHsbot :: [String] -> Env IO BotStatus
runHsbot die_msgs = do
    botNotInitialized <- asks envBotState >>= liftIO . isEmptyMVar
    when botNotInitialized runFirstSteps
    trueRunHsbot
  where
    -- | Initialize the dialog with the IRC server
    runFirstSteps :: Env IO ()
    runFirstSteps = do
        env <- ask
        -- First we say hello
        hostname <- liftIO getHostName
        let connhdl  = envHandle env
            tlsCtx   = envTLSCtx env
            config   = envConfig env
            nickname = head $ configNicknames config
            channels = configChannels config
        liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.nick nickname
        liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
        -- Then we join channels
        mapM_ (liftIO . sendStr env connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
        -- We advertise any death message we should
        mapM_ (\msg -> mapM_ (\channel -> liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs
        -- Finally we set the new bot state
        asks envBotState >>= liftIO . flip putMVar BotState { botPlugins  = M.empty
                                                            , botAccess   = configAccess config
                                                            , botHooks    = []
                                                            , botChannels = channels
                                                            , botNickname = nickname }
    -- | Run the bot itself
    trueRunHsbot :: Env IO BotStatus
    trueRunHsbot = do
        env <- ask
        -- Next we spawn the reader thread
        liftIO $ debugM "Hsbot.Core" "Spawning reader thread"
        let connhdl  = envHandle env
            tlsCtx   = envTLSCtx env
        chan <- asks envChan
        (liftIO . forkIO $ botReader env connhdl tlsCtx chan) >>= addThreadIdToQuitMVar
        -- Then we spawn all plugins
        asks envConfig >>= mapM_ loadPlugin . configPlugins
        -- Finally we spawn the main bot loop
        (liftIO . forkIO $ runReaderT botLoop env) >>= 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

botReader :: BotEnv -> Handle -> Maybe TLSCtx -> Chan Message -> IO ()
botReader env _ (Just ctx) chan = forever $
    fmap L.toString (recvData ctx) `catch` handleIOException env  "botReader died" >>= handleIncomingStr chan
botReader env handle Nothing chan = forever $
    hGetLine handle `catch` handleIOException env "botReader died" >>= handleIncomingStr chan

handleIOException :: BotEnv -> String -> IOException -> IO String
handleIOException env msg ioException = do
    runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env
    myId <- myThreadId
    killThread myId
    return ""

handleIncomingStr :: Chan Message -> String -> IO ()
handleIncomingStr chan str =
    case IRC.decode str of
        Just msg -> do
            debugM "Hsbot.Reader" $ "<-- " ++ show msg
            writeChan chan $ IncomingMsg msg
        Nothing -> return ()

botLoop :: Env IO ()
botLoop = forever $ do
    chan <- asks envChan
    msg  <- liftIO $ readChan chan
    hooks <- asks envBotState >>= liftIO . flip withMVar (return . botHooks)
    mapM_ (liftIO . flip writeChan msg) hooks
    case msg of
        IncomingMsg _ -> return () -- TODO parse for core commands
        OutgoingMsg outMsg -> do
            env <- ask
            let connhdl  = envHandle env
                tlsCtx   = envTLSCtx env
            liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg
            liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg

terminateHsbot :: Env IO ()
terminateHsbot = do
    liftIO $ infoM "Hsbot.Core" "Closing connection"
    asks envHandle >>= liftIO . hClose