-- | 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 :: Module SystemState
systemPlugin = Module SystemState
forall st. Module st
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 = \String
_ -> (IRCRWState -> Map FreenodeNick String)
-> Cmd (ModuleT SystemState LB) ()
forall k v.
Show k =>
(IRCRWState -> Map k v) -> Cmd (ModuleT SystemState LB) ()
listKeys ((ChanName -> FreenodeNick)
-> Map ChanName String -> Map FreenodeNick String
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic (Nick -> FreenodeNick
FreenodeNick (Nick -> FreenodeNick)
-> (ChanName -> Nick) -> ChanName -> FreenodeNick
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChanName -> Nick
getCN) (Map ChanName String -> Map FreenodeNick String)
-> (IRCRWState -> Map ChanName String)
-> IRCRWState
-> Map FreenodeNick String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map ChanName String
ircChannels)
            }
        , (command "listmodules")
            { help = say "listmodules. Show available plugins"
            , process = \String
_ -> String -> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT SystemState LB) ())
-> ([String] -> String)
-> [String]
-> Cmd (ModuleT SystemState LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Show a => [a] -> String
showClean ([String] -> Cmd (ModuleT SystemState LB) ())
-> Cmd (ModuleT SystemState LB) [String]
-> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [String] -> Cmd (ModuleT SystemState LB) [String]
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb LB [String]
listModules
            }
        , (command "listservers")
            { help = say "listservers. Show current servers"
            , process = \String
_ -> (IRCRWState -> Map String (DSum ModuleID ServerRef))
-> Cmd (ModuleT SystemState LB) ()
forall k v.
Show k =>
(IRCRWState -> Map k v) -> Cmd (ModuleT SystemState LB) ()
listKeys IRCRWState -> Map String (DSum ModuleID ServerRef)
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 = \String
_ -> do
                (uptime, maxUptime) <- ModuleT SystemState LB (TimeDiff, TimeDiff)
-> Cmd (ModuleT SystemState LB) (TimeDiff, TimeDiff)
forall (m :: * -> *) a. Monad m => m a -> Cmd m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ModuleT SystemState LB (TimeDiff, TimeDiff)
getUptime
                say ("uptime: "           ++ timeDiffPretty uptime ++
                     ", longest uptime: " ++ timeDiffPretty maxUptime)
            }
        
        , (command "listall")
            { privileged = True
            , help = say "list all commands"
            , process = \String
_ -> (String -> Cmd (ModuleT SystemState LB) ())
-> [String] -> Cmd (ModuleT SystemState LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT SystemState LB) ()
doList ([String] -> Cmd (ModuleT SystemState LB) ())
-> Cmd (ModuleT SystemState LB) [String]
-> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [String] -> Cmd (ModuleT SystemState LB) [String]
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb LB [String]
listModules
            }
        , (command "join")
            { privileged = True
            , help = say "join <channel>"
            , process = \String
rest -> do
                chan <- String -> Cmd (ModuleT SystemState LB) Nick
forall (m :: * -> *). Monad m => String -> Cmd m Nick
readNick String
rest
                lb $ send (joinChannel chan)
            }
        , (command "part")
            { privileged = True
            , help = say "part <channel>"
            , aliases = ["leave"]
            , process = \String
rest -> do
                chan <- String -> Cmd (ModuleT SystemState LB) Nick
forall (m :: * -> *). Monad m => String -> Cmd m Nick
readNick String
rest
                lb $ send (partChannel chan)
            }
        , (command "msg")
            { privileged = True
            , help = say "msg <nick or channel> <msg>"
            , process = \String
rest -> do
                -- writes to another location:
                let (String
tgt, String
txt) = String -> (String, String)
splitFirstWord String
rest
                tgtNick <- String -> Cmd (ModuleT SystemState LB) Nick
forall (m :: * -> *). Monad m => String -> Cmd m Nick
readNick String
tgt
                lb $ ircPrivmsg tgtNick txt
            }
        , (command "codepage")
            { privileged = True
            , help = say "codepage <server> <CP-name>"
            , process = \String
rest -> do
                let (String
server, String
cp) = String -> (String, String)
splitFirstWord String
rest
                LB () -> Cmd (ModuleT SystemState LB) ()
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> Cmd (ModuleT SystemState LB) ())
-> LB () -> Cmd (ModuleT SystemState LB) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> LB ()
ircCodepage String
server String
cp
            }
        , (command "quit")
            { privileged = True
            , help = say "quit [msg], have the bot exit with msg"
            , process = \String
rest -> do
                server <- Cmd (ModuleT SystemState LB) String
forall (m :: * -> *). Monad m => Cmd m String
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 = \String
rest -> do
                let (String
server, String
msg) = String -> (String, String)
splitFirstWord String
rest
                LB () -> Cmd (ModuleT SystemState LB) ()
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> String -> LB ()
ircQuit String
server (String -> LB ()) -> String -> LB ()
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then String
"requested" else String
msg)
            }
        , (command "flush")
            { privileged = True
            , help = say "flush. flush state to disk"
            , process = \String
_ -> LB () -> Cmd (ModuleT SystemState LB) ()
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb ((forall st. ModuleT st LB ()) -> LB ()
forall a. (forall st. ModuleT st LB a) -> LB ()
withAllModules ModuleT st LB ()
forall st. ModuleT st LB ()
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 = \String
rest -> do
                server <- Cmd (ModuleT SystemState LB) String
forall (m :: * -> *). Monad m => Cmd m String
getServer
                lb (ircReconnect server $ if null rest then "reconnect requested" else rest)
            }
        ]
    }

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

doList :: String -> Cmd System ()
doList :: String -> Cmd (ModuleT SystemState LB) ()
doList String
"" = String -> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"What module?  Try @listmodules for some ideas."
doList String
m  = String -> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT SystemState LB) ())
-> Cmd (ModuleT SystemState LB) String
-> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB String -> Cmd (ModuleT SystemState LB) String
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
listModule String
m)

doEcho :: String -> Cmd System ()
doEcho :: String -> Cmd (ModuleT SystemState LB) ()
doEcho String
rest = do
    rawMsg <- (forall a. Message a => a -> Cmd (ModuleT SystemState LB) String)
-> Cmd (ModuleT SystemState LB) String
forall (m :: * -> *) t.
Monad m =>
(forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg (String -> Cmd (ModuleT SystemState LB) String
forall a. a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Cmd (ModuleT SystemState LB) String)
-> (a -> String) -> a -> Cmd (ModuleT SystemState LB) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show)
    target <- showNick =<< getTarget
    say (concat ["echo; msg:", rawMsg, " target:" , target, " rest:", show rest])

doAdmin :: String -> Cmd System ()
doAdmin :: String -> Cmd (ModuleT SystemState LB) ()
doAdmin = ((Nick -> Set Nick -> Set Nick)
 -> Nick -> IRCRWState -> IRCRWState)
-> String -> Cmd (ModuleT SystemState LB) ()
forall a (m :: * -> *).
(Ord a, MonadLB m) =>
((a -> Set a -> Set a) -> Nick -> IRCRWState -> IRCRWState)
-> String -> Cmd m ()
toggleNick (((Nick -> Set Nick -> Set Nick)
  -> Nick -> IRCRWState -> IRCRWState)
 -> String -> Cmd (ModuleT SystemState LB) ())
-> ((Nick -> Set Nick -> Set Nick)
    -> Nick -> IRCRWState -> IRCRWState)
-> String
-> Cmd (ModuleT SystemState LB) ()
forall a b. (a -> b) -> a -> b
$ \Nick -> Set Nick -> Set Nick
op Nick
nck IRCRWState
s -> IRCRWState
s { ircPrivilegedUsers = op nck (ircPrivilegedUsers s) }

doIgnore :: String -> Cmd System ()
doIgnore :: String -> Cmd (ModuleT SystemState LB) ()
doIgnore = ((Nick -> Set Nick -> Set Nick)
 -> Nick -> IRCRWState -> IRCRWState)
-> String -> Cmd (ModuleT SystemState LB) ()
forall a (m :: * -> *).
(Ord a, MonadLB m) =>
((a -> Set a -> Set a) -> Nick -> IRCRWState -> IRCRWState)
-> String -> Cmd m ()
toggleNick (((Nick -> Set Nick -> Set Nick)
  -> Nick -> IRCRWState -> IRCRWState)
 -> String -> Cmd (ModuleT SystemState LB) ())
-> ((Nick -> Set Nick -> Set Nick)
    -> Nick -> IRCRWState -> IRCRWState)
-> String
-> Cmd (ModuleT SystemState LB) ()
forall a b. (a -> b) -> a -> b
$ \Nick -> Set Nick -> Set Nick
op Nick
nck IRCRWState
s -> IRCRWState
s { ircIgnoredUsers = op nck (ircIgnoredUsers s) }

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

--  | Print map keys
listKeys :: Show k => (IRCRWState -> M.Map k v) -> Cmd System ()
listKeys :: forall k v.
Show k =>
(IRCRWState -> Map k v) -> Cmd (ModuleT SystemState LB) ()
listKeys IRCRWState -> Map k v
f = String -> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT SystemState LB) ())
-> (Map k v -> String)
-> Map k v
-> Cmd (ModuleT SystemState LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [k] -> String
forall a. Show a => [a] -> String
showClean ([k] -> String) -> (Map k v -> [k]) -> Map k v -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [k]
forall k a. Map k a -> [k]
M.keys (Map k v -> Cmd (ModuleT SystemState LB) ())
-> Cmd (ModuleT SystemState LB) (Map k v)
-> Cmd (ModuleT SystemState LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB (Map k v) -> Cmd (ModuleT SystemState LB) (Map k v)
forall a. LB a -> Cmd (ModuleT SystemState LB) a
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb ((IRCRWState -> Map k v) -> LB (Map k v)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map k v
f)

getUptime :: System (TimeDiff, TimeDiff)
getUptime :: ModuleT SystemState LB (TimeDiff, TimeDiff)
getUptime = do
    (loaded, m) <- ModuleT SystemState LB SystemState
ModuleT SystemState LB (LBState (ModuleT SystemState LB))
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
    now         <- io getClockTime
    let diff = ClockTime
now ClockTime -> ClockTime -> TimeDiff
`diffClockTimes` ClockTime
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 :: forall a (m :: * -> *).
(Ord a, MonadLB m) =>
((a -> Set a -> Set a) -> Nick -> IRCRWState -> IRCRWState)
-> String -> Cmd m ()
toggleNick (a -> Set a -> Set a) -> Nick -> IRCRWState -> IRCRWState
edit String
rest = do
    let (String
op, String
tgt) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
2 String
rest
    
    f <- case String
op of
        String
"+ " -> (a -> Set a -> Set a) -> Cmd m (a -> Set a -> Set a)
forall a. a -> Cmd m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert
        String
"- " -> (a -> Set a -> Set a) -> Cmd m (a -> Set a -> Set a)
forall a. a -> Cmd m a
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete
        String
_    -> String -> Cmd m (a -> Set a -> Set a)
forall a. String -> Cmd m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid usage"
    
    nck <- readNick tgt
    lb . modify $ edit f nck

listModule :: String -> LB String
listModule :: String -> LB String
listModule String
s = String
-> LB String -> (forall st. ModuleT st LB String) -> LB String
forall a. String -> LB a -> (forall st. ModuleT st LB a) -> LB a
inModuleNamed String
s LB String
fromCommand ModuleT st LB String
forall st. ModuleT st LB String
printProvides
  where
    fromCommand :: LB String
fromCommand = String
-> LB String
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB String)
-> LB String
forall a.
String
-> LB a
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB a)
-> LB a
withCommand String
s
        (String -> LB String
forall a. a -> LB a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> LB String) -> String -> LB String
forall a b. (a -> b) -> a -> b
$ String
"No module \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" loaded") (ModuleT st LB String
-> Command (ModuleT st LB) -> ModuleT st LB String
forall a b. a -> b -> a
const ModuleT st LB String
forall st. ModuleT st LB String
printProvides)

    printProvides :: ModuleT st LB String
    printProvides :: forall st. ModuleT st LB String
printProvides = do
        cmds <- Module st -> ModuleT st LB [Command (ModuleT st LB)]
forall st. Module st -> ModuleT st LB [Command (ModuleT st LB)]
moduleCmds (Module st -> ModuleT st LB [Command (ModuleT st LB)])
-> ModuleT st LB (Module st)
-> ModuleT st LB [Command (ModuleT st LB)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ModuleInfo st -> Module st) -> ModuleT st LB (Module st)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ModuleInfo st -> Module st
forall st. ModuleInfo st -> Module st
theModule
        let cmds' = (Command (ModuleT st LB) -> Bool)
-> [Command (ModuleT st LB)] -> [Command (ModuleT st LB)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Command (ModuleT st LB) -> Bool)
-> Command (ModuleT st LB)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command (ModuleT st LB) -> Bool
forall (m :: * -> *). Command m -> Bool
privileged) [Command (ModuleT st LB)]
cmds
        name' <- asks moduleName
        return . concat $ if null cmds'
                          then [name', " has no visible commands"]
                          else [name', " provides: ", showClean (concatMap cmdNames cmds')]