summaryrefslogtreecommitdiff
path: root/Hsbot/Command.hs
blob: f42db98d9e1dd5b84d9962d97d7414c5ccce8abf (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
module Hsbot.Command
    ( dispatchMessage
    , processInternalCommand
    , registerCommand
    , unregisterCommand
    ) where

import Control.Monad.State
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe

import Config
import Hsbot.Plugin
import Hsbot.Types
import Hsbot.Utils

-- | Registers a plugin's command
registerCommand :: String -> String -> IrcBot ()
registerCommand cmd pluginName' = do
    bot     <- get
    cmds    <- gets botCommands
    plugins <- gets botPlugins
    case M.lookup pluginName' plugins of
        Just _  -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ?
                       newCmds     = M.insert cmd pluginNames cmds
                   in  put $ bot { botCommands = newCmds }
        Nothing -> traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \""
                                     ++ pluginName' ++ "\" : plugin does not exists") [31]

-- | Unregisters a plugin's command
unregisterCommand :: String -> String -> IrcBot ()
unregisterCommand cmd pluginName' = do
    bot    <- get
    cmds   <- gets botCommands
    let newCmds = M.adjust (L.delete pluginName') cmd cmds
    put $ bot { botCommands = newCmds }

-- | Dispatches an input message
dispatchMessage :: BotMsg -> IrcBot ()
dispatchMessage (InputMsg inputMsg) = do
    plugins <- gets botPlugins
    cmds    <- gets botCommands
    if isPluginCommand  --TODO : how to get rid of this if?
      then
        let key         = tail $ head $ words getMsgContent
            pluginNames = fromMaybe [] $ M.lookup key cmds
            plugins'    = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
        in mapM_ (sendRunCommand $ tail getMsgContent) plugins'
      else
        mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins)
  where
    isPluginCommand :: Bool
    isPluginCommand =
        and [ command inputMsg == "PRIVMSG"
            , (head getMsgContent) == (commandPrefix config) ]
    sendRunCommand :: String -> Plugin -> IrcBot ()
    sendRunCommand cmd plugin = do
        sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd) plugin
    getMsgContent :: String
    getMsgContent = unwords . tail $ parameters inputMsg
dispatchMessage _ = return ()

-- | Processes an internal command
processInternalCommand :: BotMsg -> IrcBot ()
processInternalCommand (InternalCmd intCmd) = do
    plugins <- gets botPlugins
    if intCmdTo intCmd == "CORE"
      then processCoreCommand intCmd
      else case M.lookup (intCmdTo intCmd) plugins of
          Just plugin -> sendToPlugin (InternalCmd intCmd) plugin
          Nothing     -> errorM $ "Invalid destination in message : " ++ (show intCmd)
processInternalCommand _ = return ()

-- | Processes a core command
processCoreCommand :: IntCmd -> IrcBot ()
processCoreCommand intCmd = do
    let command' = intCmdCmd intCmd
    case command' of
        "LOAD"       -> traceM $ inColor "hsbot has been compiled in static mode." [31]
        "UNLOAD"     -> unloadPlugin $ intCmdMsg intCmd
        "REGISTER"   -> registerCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
        "UNREGISTER" -> unregisterCommand (intCmdMsg intCmd) (intCmdFrom intCmd)
        _            -> traceM $ inColor ("Invalid command : " ++ (show intCmd)) [31]