System.hs

-- | System module : IRC control functions
module Lambdabot.Plugin.Core.System (systemPlugin) where

import Lambdabot.Bot
import Lambdabot.Compat.AltTime
import Lambdabot.Compat.FreenodeNick
import Lambdabot.IRC
import Lambdabot.Module
import Lambdabot.Monad
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Monad.Reader
import Control.Monad.State (gets, modify)
import qualified Data.Map as M
import qualified Data.Set as S

type SystemState = (ClockTime, TimeDiff)
type System = ModuleT SystemState LB

systemPlugin :: Module SystemState
systemPlugin = newModule
    { moduleDefState = flip (,) noTimeDiff `fmap` io getClockTime
    , moduleSerialize  = Just stdSerial

    , moduleInit = do
        (_, d) <- readMS
        t      <- io getClockTime
        writeMS (t, d)
    , moduleExit = do
        (initial, d) <- readMS
        now          <- liftIO getClockTime
        writeMS (initial, max d (diffClockTimes now initial))
    
    , moduleCmds = return $
        [ (command "listchans")
            { help = say "Show channels bot has joined"
            , process = \_ -> listKeys (M.mapKeysMonotonic (FreenodeNick . getCN) . ircChannels)
            }
        , (command "listmodules")
            { help = say "listmodules. Show available plugins"
            , process = \_ -> say . showClean =<< lb listModules
            }
        , (command "listservers")
            { help = say "listservers. Show current servers"
            , process = \_ -> listKeys ircServerMap
            }
        , (command "list")
            { help = say "list [module|command]. Show commands for [module] or the module providing [command]."
            , process = doList
            }
        , (command "echo")
            { help = say "echo <msg>. echo irc protocol string"
            , process = doEcho
            }
        , (command "uptime")
            { help = say "uptime. Show uptime"
            , process = \_ -> do
                (uptime, maxUptime) <- lift getUptime
                say ("uptime: "           ++ timeDiffPretty uptime ++
                     ", longest uptime: " ++ timeDiffPretty maxUptime)
            }
        
        , (command "listall")
            { privileged = True
            , help = say "list all commands"
            , process = \_ -> mapM_ doList =<< lb listModules
            }
        , (command "join")
            { privileged = True
            , help = say "join <channel>"
            , process = \rest -> do
                chan <- readNick rest
                lb $ send (joinChannel chan)
            }
        , (command "part")
            { privileged = True
            , help = say "part <channel>"
            , aliases = ["leave"]
            , process = \rest -> do
                chan <- readNick rest
                lb $ send (partChannel chan)
            }
        , (command "msg")
            { privileged = True
            , help = say "msg <nick or channel> <msg>"
            , process = \rest -> do
                -- writes to another location:
                let (tgt, txt) = splitFirstWord rest
                tgtNick <- readNick tgt
                lb $ ircPrivmsg tgtNick txt
            }
        , (command "codepage")
            { privileged = True
            , help = say "codepage <server> <CP-name>"
            , process = \rest -> do
                let (server, cp) = splitFirstWord rest
                lb $ ircCodepage server cp
            }
        , (command "quit")
            { privileged = True
            , help = say "quit [msg], have the bot exit with msg"
            , process = \rest -> do
                server <- getServer
                lb (ircQuit server $ if null rest then "requested" else rest)
            }
        , (command "disconnect")
            { privileged = True
            , help = say "disconnect <server> [msg], disconnect from a server with msg"
            , process = \rest -> do
                let (server, msg) = splitFirstWord rest
                lb (ircQuit server $ if null msg then "requested" else msg)
            }
        , (command "flush")
            { privileged = True
            , help = say "flush. flush state to disk"
            , process = \_ -> lb (withAllModules writeGlobalState)
                
            }
        , (command "admin")
            { privileged = True
            , help = say "admin [+|-] nick. change a user's admin status."
            , process = doAdmin
            }
        , (command "ignore")
            { privileged = True
            , help = say "ignore [+|-] nick. change a user's ignore status."
            , process = doIgnore
            }
        , (command "reconnect")
            { privileged = True
            , help = say "reconnect to server"
            , process = \rest -> do
                server <- getServer
                lb (ircReconnect server $ if null rest then "reconnect requested" else rest)
            }
        ]
    }

------------------------------------------------------------------------

doList :: String -> Cmd System ()
doList "" = say "What module?  Try @listmodules for some ideas."
doList m  = say =<< lb (listModule m)

doEcho :: String -> Cmd System ()
doEcho rest = do
    rawMsg <- withMsg (return . show)
    target <- showNick =<< getTarget
    say (concat ["echo; msg:", rawMsg, " target:" , target, " rest:", show rest])

doAdmin :: String -> Cmd System ()
doAdmin = toggleNick $ \op nck s -> s { ircPrivilegedUsers = op nck (ircPrivilegedUsers s) }

doIgnore :: String -> Cmd System ()
doIgnore = toggleNick $ \op nck s -> s { ircIgnoredUsers = op nck (ircIgnoredUsers s) }

------------------------------------------------------------------------

--  | Print map keys
listKeys :: Show k => (IRCRWState -> M.Map k v) -> Cmd System ()
listKeys f = say . showClean . M.keys =<< lb (gets f)

getUptime :: System (TimeDiff, TimeDiff)
getUptime = do
    (loaded, m) <- readMS
    now         <- io getClockTime
    let diff = now `diffClockTimes` loaded
    return (diff, max diff m)

toggleNick :: (Ord a, MonadLB m) =>
    ((a -> S.Set a -> S.Set a) -> Nick -> IRCRWState -> IRCRWState)
    -> String -> Cmd m ()
toggleNick edit rest = do
    let (op, tgt) = splitAt 2 rest
    
    f <- case op of
        "+ " -> return S.insert
        "- " -> return S.delete
        _    -> fail "invalid usage"
    
    nck <- readNick tgt
    lb . modify $ edit f nck

listModule :: String -> LB String
listModule s = inModuleNamed s fromCommand printProvides
  where
    fromCommand = withCommand s
        (return $ "No module \""++s++"\" loaded") (const printProvides)

    printProvides :: ModuleT st LB String
    printProvides = do
        cmds <- moduleCmds =<< asks theModule
        let cmds' = filter (not . privileged) cmds
        name' <- asks moduleName
        return . concat $ if null cmds'
                          then [name', " has no visible commands"]
                          else [name', " provides: ", showClean (concatMap cmdNames cmds')]