Infinity/Main.hs

   1 {-# OPTIONS_HADDOCK ignore-exports, prune #-}
   2 #ifdef STATIC_BUILD
   3 -- | The bot's brain.
   4 -- NOTE: This is the static build of infinity,
   5 -- documentation for imain and imain' has not
   6 -- been generated
   7 #else
   8 -- | The bot's brain.
   9 -- NOTE: This is the dynamic build of infinity,
  10 -- documentation for staticmain has not been
  11 -- generated.
  12 #endif
  13 module Infinity.Main (
  14 #ifndef STATIC_BUILD
  15  imain,imain',
  16 #else
  17  staticmain,
  18 #endif
  19  offlinemode
  20 ) where
  21 import qualified Network.IRC as IRC
  22 import qualified Data.Map as M
  23 import qualified Data.Set as S
  24 import qualified Config as C
  25 import System.Console.Readline
  26 import Control.Concurrent.STM
  27 import Control.Concurrent
  28 import Network.Socket
  29 #ifndef STATIC_BUILD
  30 import System.Plugins
  31 #endif
  32 import Control.Monad
  33 import Text.Printf
  34 import System.Exit
  35 import System.IO
  36 import Data.List
  37 import Network
  38 -- infinity-related stuff
  39 import Infinity.Plugins
  40 import Infinity.State
  41 import Infinity.Util
  42 import Infinity.Core
  43 import Infinity.IRC
  44 import Infinity.Log
  45
  46 #ifndef STATIC_BUILD
  47 -- | Reboot data type
  48 type Reboot   = (Module -> Bot -> IO ())
  49 #endif
  50
  51 -- | Data that can go over the remote channel
  52 data RemoteLine
  53     = Str String              -- ^ A regular string
  54     | Quit (Server,Handle)    -- ^ A quit message from a server
  55     | Join (Server,Channel)   -- ^ Joined a channel
  56     | Part (Server,Channel)   -- ^ Parted the channel
  57     | Reboot                  -- ^ Reboot message sent
  58     | Nil                     -- ^ Signifies thread death,
  59                               --   only happens after reboot
  60  deriving (Eq,Show)
  61
  62
  63 -- | The bot\'s static entry point; used
  64 -- when not built with -fdynamic
  65 staticmain :: IO ()
  66 staticmain = do
  67   -- connect to all servers
  68   bot     <- startup
  69   rchan   <- newChan
  70   logs Normal "Initializing plugins..."
  71   plugins <- initplugins (C.enabledplugins C.config)
  72
  73   -- setup static servers
  74   let Bot x = bot
  75   mapM_ setup (M.toList x)
  76   mapM_ (forkIO . listener plugins rchan Nothing) (M.toList x)
  77   let bot'  = joinservs (M.toList x) bot
  78   logs Normal "Joined channels and identified..."
  79   monitor plugins rchan undefined bot'
  80   return ()
  81
  82 #ifndef STATIC_BUILD
  83 -- | Bot\'s FIRST dynamic entry point
  84 imain :: Module -> Reboot -> IO ()
  85 imain mod reboot = imain' mod reboot newbot
  86
  87 -- | The bot\'s dynamic entry point that we jump to from 'imain'
  88 imain' :: Module -> Reboot -> Bot -> IO ()
  89 imain' mod reboot bot = do
  90   logs Normal "Initializing plugins..."
  91   plugins   <- initplugins (C.enabledplugins C.config)
  92   rchan     <- newChan :: IO (Chan RemoteLine)
  93   rebootvar <- atomically $ newEmptyTMVar -- when a reboot is sent, this is set
  94
  95   -- we connect to any newly added servers
  96   let newservs = filter (not . servexists bot) (C.servers C.config)
  97   servs' <- mapM servcon newservs
  98   mapM_ setup servs'
  99
 100   -- set up all new servers
 101   let bot'  = joinservs servs' bot
 102       Bot x = bot'
 103   mapM_ (forkIO . listener plugins rchan (Just rebootvar)) (M.toList x)
 104   logs Normal "Joined channels & Identified..."
 105   b' <- monitor plugins rchan rebootvar bot'
 106   reboot mod b'
 107 #endif
 108
 109 -- | If infinity is built and the '-offline' command is specified,
 110 -- then it will jump here and it will be a console interface.
 111 offlinemode :: IO ()
 112 offlinemode = do
 113   x <- initplugins (C.enabledplugins C.config)
 114   shell x $ IContext Nothing x Nothing
 115       where shell plugs ctx = do
 116                 s <- readline "> "
 117                 case s of
 118                   Nothing     -> shell plugs ctx
 119                   Just "quit" -> exitWith ExitSuccess
 120                   Just s'     -> do
 121                           addHistory s'
 122                           let (cmd,av) = span (/=' ') s'
 123                               av' = if null av then Nothing
 124                                      else Just (drop 1 av)
 125                           (str,x') <- runplugin ctx plugs cmd av'
 126                           putStrLn str >> shell x' ctx
 127
 128 -- | This is the bot's main loop. After it gets rebooted or starts
 129 -- for the first time, it initializes all plugins, spawns a thread
 130 -- for each server, and then jumps here. This monitors when threads
 131 -- quit, it waits for them to join, serializes plugin state, and
 132 -- other tasks.
 133 monitor :: [IModule] -> Chan RemoteLine -> TMVar Bool -> Bot -> IO Bot
 134 monitor plugins rchan rebootvar bot = do
 135   mlog Normal "Server's connected, threads forked..."
 136   loop bot
 137       where check b    = when (servnum b == 0) $ do
 138                            mlog Normal "All servers disconnected, quitting..."
 139                            exitWith ExitSuccess
 140             wait n s i = when (i < n) $
 141                          case s of
 142                            Nil:xs -> wait n xs $! i+1
 143                            _:xs   -> wait n xs i
 144             loop b     = do
 145               check b
 146               l <- readChan rchan
 147               case l of
 148                 Str s   -> putStrLn s >> loop b
 149                 Quit (s,h) -> do
 150                            hClose h
 151                            loop $! (partserv s b)
 152                 Join (s,c) -> let x = updateserv (joinchan c s) b in loop $! x
 153                 Part (s,c) -> let x = updateserv (joinchan c s) b in loop $! x
 154 #ifdef STATIC_BUILD
 155                 Reboot -> loop b
 156 #else
 157                 Reboot -> do
 158                   mlog Normal "Got Reboot message"
 159                   atomically $ putTMVar rebootvar True
 160                   s <- getChanContents rchan
 161                   wait (servnum b) s 0
 162                   return b
 163 #endif
 164
 165 -- | This is the entry point for threads that listen on sockets for
 166 -- messages
 167 listener :: [IModule] -> Chan RemoteLine -> Maybe (TMVar Bool) -> (Server,Handle) -> IO ()
 168 listener plugins rchan rebootvar x@(serv,handle) = infinity $ do
 169   str <- hGetLine handle
 170   writeChan rchan (Str str)
 171   if ping str then pong handle str
 172    else eval (ircParser str)
 173  where eval s | (Err e)            <- s = logs Error ("eval err: "++e)
 174               | (Line u c x)       <- s = irclog (address serv) (u,c,x)
 175               | (Cmd u c (cmd,av)) <- s = do
 176                   let cmd' = tail cmd
 177                   case av of
 178                     Nothing   -> irclog (address serv) (u,c,cmd)
 179                     Just args -> irclog (address serv) (u,c,unwords [cmd,args])
 180                   unless (null cmd') (parseCmds u cmd' av c $ IContext (Just serv) plugins (Just handle))
 181        parseCmds u c av chan ctx
 182            | "join"   == c = when (isadmin u serv) $ case av of
 183                                Just av' -> joinC handle av' >> writeChan rchan (Join (serv,av'))
 184                                Nothing  -> privmsg handle chan "Need a channel to join..."
 185            | "part"   == c = when (isadmin u serv) $ case av of
 186                                Just av' -> partC handle av' >> writeChan rchan (Part (serv,av'))
 187                                Nothing  -> partC handle chan >> writeChan rchan (Part (serv,chan))
 188 --         | "quit"   == c = writeChan rchan (Quit (serv,handle))
 189 --         | "reboot" == c = writeChan rchan Reboot
 190            | otherwise     = do
 191               (str,plugins') <- runplugin ctx plugins c av
 192 #ifdef DEBUG
 193               logs Normal $ "Output of \'"++cmd'++"\', with args \'"++(show av)++"\':   "++str
 194 #endif
 195               mapM_ (\s -> privmsg handle chan s >>
 196                            irclog (address serv) ((nickname serv),chan,s)) (lines str)
 197
 198
 199 --------------------------------
 200 -- Utilities
 201 --------------------------------
 202 -- | Loops a function unless 'b' is False
 203 infinity :: IO () -> IO ()
 204 infinity a = a >> infinity a
 205
 206 -- | Sends a message over a Handle
 207 sendH :: Handle -> String -> IO ()
 208 sendH h = hPrintf h "%s\r\n"
 209
 210 -- | Sends a private message over a handle
 211 privmsg :: Handle -> String -> String -> IO ()
 212 privmsg h c s = sendH h $ IRC.encode (IRC.privmsg c s)
 213
 214 -- | Joins a channel by sending the message over the handle
 215 joinC :: Handle -> String -> IO ()
 216 joinC h = sendH h . IRC.encode . IRC.joinChan
 217
 218 -- | Parts a channel by sending the message over the handle
 219 partC :: Handle -> String -> IO ()
 220 partC h = sendH h . IRC.encode . IRC.part
 221
 222 -- | Check if a message is a PING
 223 ping :: String -> Bool
 224 ping = isPrefixOf "PING :"
 225
 226 -- | Send a pong message given a ping message
 227 -- previously
 228 pong :: Handle -> String -> IO ()
 229 pong h s = sendH h $ "PONG " ++ (drop 5 s)
 230
 231 -- | our parser for irc msgs.
 232 ircParser = parseIRCmsg (C.commandPrefixes C.config)
 233
 234 -- | Starts up the bot with initial configuration and
 235 -- | whatnot, used by staticmain
 236 startup = do
 237   hSetBuffering stdout NoBuffering
 238   logs Normal "Connecting to servers..."
 239   servs <- mapM servcon (C.servers C.config)
 240     -- add these new servers to bot state
 241   let bot = joinservs servs newbot
 242   logs Normal "Connected to servers..."
 243   return bot
 244
 245 -- | Connects to a server
 246 servcon s = do
 247   let name  = address s
 248       portn = port s
 249   h <- connectTo name (PortNumber $ fromIntegral portn)
 250   hSetBuffering h NoBuffering
 251   return (s,h)
 252
 253
 254 -- | Sets up a newly created server connection,
 255 -- by sending the User, nick, and password messages
 256 -- as well as joining channels.
 257 setup x@(serv,handle) = do
 258   -- setup authentication and stuff
 259   sendstr handle (IRC.encode $ IRC.nick (nickname serv))                                -- nick
 260   sendstr handle (IRC.encode $ IRC.user (nickname serv) "0" "*" (realname serv))        -- realname
 261   when (not . null $ (password serv)) $ do
 262     sendstr handle (IRC.encode $ IRC.privmsg "nickserv" ("identify "++(password serv))) -- password
 263   mapM_ (sendstr handle . IRC.encode . IRC.joinChan) (S.toList $ channels serv)         -- channels
 264   return ()
 265
 266 -- | Send a string over handle
 267 sendstr h str = hPrintf h "%s\r\n" str