Session.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module:     Network.FastIRC.Session
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  alpha
--
-- This module implements a framework for IRC client software.
-- Essentially it consists of a dumb bot, which connects to and stays on
-- an IRC server waiting for commands.
--
-- Using the 'onEvent' function (or the convenience functions
-- 'onConnect', 'onDisconnect', etc.) you can attach event handlers to
-- certain events.  These event handlers are run in the 'Bot' monad,
-- which encapsulates the current state of the bot.
--
-- Please note that even though unlikely you should expect that parts of
-- this interface will be changed in future revisions.

module Network.FastIRC.Session
  ( -- * Types
    Bot,
    BotCommand(..),
    BotInfo(..),
    BotSession,
    Event(..),
    EventHandler,
    Params(..),

    -- * Functions
    ircSendCmd,
    ircSendMsg,
    ircSendString,
    onEvent,
    sendBotCmd,
    startBot,

    -- * Event utility functions
    onConnect,
    onDisconnect,
    onError,
    onLoggedIn,
    onMessage,
    onQuit,

    -- * Bot monad
    getBotInfo
  )
  where

import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Control.Applicative
import Control.Concurrent
import Data.Map (Map)
import Data.Unique
import MonadLib
import Network.Fancy
import Network.FastIRC.IO
import Network.FastIRC.Messages
import Network.FastIRC.ServerSet
import Network.FastIRC.Types
import System.IO


-- | Bot monad.

type Bot = ContT () (StateT Config (ReaderT Params IO))


-- | Commands to be sent to the bot.

data BotCommand
  -- | Add an event handler.
  = BotAddHandler (EventHandler -> IO ()) (Event -> Bot ())
  | BotDispatch Event          -- ^ Dispatch simulated event.
  | BotError String            -- ^ Simulate an error.
  | BotQuit (Maybe CommandArg) -- ^ Send a quit message.
  | BotRecv Message            -- ^ Simulate receiving of a message.
  | BotSendCmd Command         -- ^ Send a command to the IRC server.
  | BotSendMsg Message         -- ^ Send a message to the IRC server.
  | BotSendString MsgString    -- ^ Send a raw string to the IRC server.
  | BotTerminate               -- ^ Immediately kill the bot.


-- | Runtime bot information.

data BotInfo =
  BotInfo {
    botCurrentNick :: Maybe NickName
  }


-- | Bot session descriptor.

data BotSession =
  BotSession {
    botCmdChan :: Chan BotCommand  -- ^ Command channel.
  }


-- | Bot configuration at run-time.

data Config =
  Config {
    -- | Event handlers.
    botEventHandlers :: Map EventHandler (Event -> Bot ()),
    botEventChan     :: Chan Event, -- ^ Event channel.
    botHandle        :: Handle,     -- ^ Connection handle.
    botInfo          :: BotInfo,    -- ^ Current information.
    botIsQuitting    :: Bool,       -- ^ Quit command issued?
    botKillerThread  :: Maybe ThreadId, -- ^ Killer thread.
    botServers       :: ServerSet,  -- ^ Nicknames known to be servers.
    botSession       :: BotSession  -- ^ Session information.
  }


-- | A bot event.

data Event
  = ConnectedEvent       -- ^ Bot connected.
  | DisconnectedEvent    -- ^ Bot disconnected (either error or on demand).
  | ErrorEvent String    -- ^ Connection failed or disconnected on error.
  | LoggedInEvent        -- ^ Bot logged in (received numeric 001).
  | MessageEvent Message -- ^ Received message from server.
  | QuitEvent            -- ^ Bot disconnected on demand.
  deriving (Eq, Read, Show)


-- | Event handler identifier.

type EventHandler = Unique


-- | Parameters for an IRC client connection.

data Params =
  Params {
    botGetNick     :: IO NickName,      -- ^ IRC nick name generator.
    botGetUser     :: IO UserName,      -- ^ IRC user name generator.
    botGetRealName :: IO RealName,      -- ^ IRC real name generator.
    botPassword    :: Maybe CommandArg, -- ^ IRC server password.
    botServerAddr  :: Address           -- ^ IRC server address.
  }


-- | Core bot management thread.

botManager :: Params -> Config -> IO ()
botManager params cfg = do
  -- Initialize bot.
  let eventChan = botEventChan $ cfg
      cmdChan = botCmdChan . botSession $ cfg
      h = botHandle $ cfg

  writeChan eventChan ConnectedEvent

  dispatchThread <- forkIO $
    getChanContents eventChan >>= writeList2Chan cmdChan . map BotDispatch

  netThread <- forkIO $ networkHandler cmdChan (botHandle cfg)

  -- Main loop.
  runBot params cfg $ do
    sendLogin
    forever $ do
      bcmd <- inBase $ readChan cmdChan
      case bcmd of
        BotAddHandler reportId f -> do
          hid <- inBase newUnique
          handlers <- botEventHandlers <$> get
          sets_ (\cfg -> cfg { botEventHandlers = M.insert hid f handlers })
          inBase $ reportId hid

        BotDispatch ev -> do
          handlerList <- M.elems . botEventHandlers <$> get
          mapM_ ($ ev) handlerList

        BotError err -> do
          isQuitting <- botIsQuitting <$> get
          unless isQuitting . inBase . writeChan eventChan $ ErrorEvent err
          die

        BotQuit reason -> do
          inBase $ hPutCommand h (QuitCmd reason)
          ktid <- inBase . forkIO $
                    threadDelay 1000000 >>
                    writeChan cmdChan BotTerminate
          sets_ $ \cfg -> cfg { botIsQuitting = True,
                                botKillerThread = Just ktid }

        BotRecv msg ->
          inBase (writeChan eventChan $ MessageEvent msg) >>
          handleMsg msg

        BotSendCmd cmd    -> inBase $ hPutCommand h cmd
        BotSendMsg msg    -> inBase $ hPutMessage h msg
        BotSendString str -> inBase $ B.hPutStr h str
        BotTerminate      -> die

  -- Clean up.
  killThread dispatchThread
  killThread netThread

  where
    networkHandler :: Chan BotCommand -> Handle -> IO ()
    networkHandler cmdChan h = do
      res <- try $ hGetMessage h
      case res of
        Left err  -> writeChan cmdChan $ BotError (show err)
        Right msg ->
          writeChan cmdChan (BotRecv msg) >>
          networkHandler cmdChan h

    die :: Bot ()
    die = do
      isQuitting <- botIsQuitting <$> get
      ktidM <- botKillerThread <$> get
      handlerList <- M.elems . botEventHandlers <$> get
      when isQuitting $ mapM_ ($ QuitEvent) handlerList
      case ktidM of
        Just ktid -> inBase $ killThread ktid
        Nothing   -> return ()
      mapM_ ($ DisconnectedEvent) handlerList
      abort ()


-- | Default bot information.

defBotInfo :: BotInfo
defBotInfo =
  BotInfo { botCurrentNick = Nothing }


-- | Handle an incoming IRC message.

handleMsg :: Message -> Bot ()
handleMsg msg = do
  h <- botHandle <$> get
  let origin = msgOrigin msg
      cmd    = msgCommand msg
  eventChan <- botEventChan <$> get

  case cmd of
    NumericCmd 1 (myNick:_) -> do
      inBase $ writeChan eventChan LoggedInEvent
      sets_ $ \cfg -> let bi = (botInfo cfg) { botCurrentNick = Just myNick }
                      in cfg { botInfo = bi }

    PingCmd a b -> inBase $ hPutCommand h (PongCmd a b)

    _ -> return ()


-- | Send a command to the IRC server.

ircSendCmd :: BotSession -> Command -> IO ()
ircSendCmd bs = sendBotCmd bs . BotSendCmd


-- | Send a message (with origin) to the IRC server.  Note that IRC
-- servers ignore the origin prefix, so in general you would want to use
-- 'ircSendCmd' instead.

ircSendMsg :: BotSession -> Message -> IO ()
ircSendMsg bs = sendBotCmd bs . BotSendMsg


-- | Send a raw message string to the IRC server.  This is what most IRC
-- clients call /quote.

ircSendString :: BotSession -> MsgString -> IO ()
ircSendString bs = sendBotCmd bs . BotSendString


-- | Add an event handler.

onEvent :: BotSession -> (Event -> Bot ()) -> IO EventHandler
onEvent bs f = do
  let cmdChan = botCmdChan bs
  answerVar <- newEmptyMVar
  writeChan cmdChan $ BotAddHandler (putMVar answerVar) f
  takeMVar answerVar


-- | Run a 'Bot' monad computation.

runBot :: Params -> Config -> Bot () -> IO ()
runBot params cfg =
  fmap fst .
  runReaderT params .
  runStateT cfg .
  runContT return


-- | Send bot command to a bot.

sendBotCmd :: BotSession -> BotCommand -> IO ()
sendBotCmd bs cmd = writeChan (botCmdChan bs) cmd


-- | Send login commands.

sendLogin :: Bot ()
sendLogin = do
  h <- botHandle <$> get
  nick <- asks botGetNick >>= inBase
  user <- asks botGetUser >>= inBase
  real <- asks botGetRealName >>= inBase
  addr <- asks botServerAddr
  pass <- asks botPassword
  let (host, port) =
        case addr of
          IP h p   -> (B.pack h, B.pack $ show p)
          IPv4 h p -> (B.pack h, B.pack $ show p)
          IPv6 h p -> (B.pack h, B.pack $ show p)
          _        -> ("localhost", "6667")

  inBase $ do
    case pass of
      Just pwd -> hPutCommand h $ PassCmd pwd
      Nothing  -> return ()

    hPutCommand h $ NickCmd nick Nothing
    hPutCommand h $ UserCmd user host port real


-- | Launch an IRC bot.

startBot :: Params -> IO (Either IOError BotSession)
startBot params = do
  cmdChan <- newChan
  eventChan <- newChan
  errorVar <- newEmptyMVar
  let session = BotSession { botCmdChan = cmdChan }

  forkIO $
    let comp =
          withStream (botServerAddr params) $ \h ->
            let cfg =
                  Config {
                    botEventHandlers = M.empty,
                    botEventChan = eventChan,
                    botHandle = h,
                    botInfo = defBotInfo,
                    botIsQuitting = False,
                    botKillerThread = Nothing,
                    botServers = emptyServers,
                    botSession = session
                  }
            in do
              hSetBuffering h NoBuffering
              putMVar errorVar Nothing
              res <- try $ botManager params cfg
              case res of
                Left err -> do
                  hPutStrLn stderr "Warning (fastirc): unexpected exception:"
                  hPrint stderr err
                  hPutStrLn stderr "Please report this to the author."
                Right _ -> return ()
    in comp `catch` (putMVar errorVar . Just)

  error <- takeMVar errorVar
  case error of
    Nothing  -> return (Right session)
    Just err -> return (Left err)


-- | Action to run on connect.
onConnect :: BotSession -> Bot () -> IO EventHandler
onConnect bs c = onEvent bs $ \ev -> case ev of ConnectedEvent -> c; _ -> return ()

-- | Action to run on disconnect.
onDisconnect :: BotSession -> Bot () -> IO EventHandler
onDisconnect bs c = onEvent bs $ \ev -> case ev of DisconnectedEvent -> c; _ -> return ()

-- | Action to run on error (connection failed/aborted).
onError :: BotSession -> (String -> Bot ()) -> IO EventHandler
onError bs f = onEvent bs $ \ev -> case ev of ErrorEvent str -> f str; _ -> return ()

-- | Action to run after login (numeric 001 received).
onLoggedIn :: BotSession -> Bot () -> IO EventHandler
onLoggedIn bs c = onEvent bs $ \ev -> case ev of LoggedInEvent -> c; _ -> return ()

-- | Action to run when a message arrives.
onMessage :: BotSession -> (Message -> Bot ()) -> IO EventHandler
onMessage bs f = onEvent bs $ \ev -> case ev of MessageEvent msg -> f msg; _ -> return ()

-- | Action to run on quit.
onQuit :: BotSession -> Bot () -> IO EventHandler
onQuit bs c = onEvent bs $ \ev -> case ev of QuitEvent -> c; _ -> return ()


-- | Get current bot information.

getBotInfo :: Bot BotInfo
getBotInfo = botInfo <$> get