{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | The guts of lambdabot.
--
-- The LB/Lambdabot monad
-- Generic server connection,disconnection
-- The module typeclass, type and operations on modules
module Lambdabot.Bot
    ( ircLoadModule
    , ircUnloadModule
    , checkPrivs
    , checkIgnore
    
    , ircCodepage
    , ircGetChannels
    , ircQuit
    , ircReconnect
    , ircPrivmsg
    , ircPrivmsg'
    ) where

import Lambdabot.ChanName
import Lambdabot.Config
import Lambdabot.Config.Core
import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Message
import Lambdabot.Module
import Lambdabot.Monad
import Lambdabot.Nick
import Lambdabot.State

import Control.Concurrent
import Control.Exception.Lifted as E
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as M
import Data.Random.Source
import qualified Data.Set as S

------------------------------------------------------------------------
--
-- | Register a module in the irc state
--
ircLoadModule :: String -> Module st -> LB ()
ircLoadModule :: String -> Module st -> LB ()
ircLoadModule String
mName Module st
m = do
    String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
infoM (String
"Loading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
mName)
    
    Maybe st
savedState <- Module st -> String -> LB (Maybe st)
forall st. Module st -> String -> LB (Maybe st)
readGlobalState Module st
m String
mName
    st
mState     <- LB st -> (st -> LB st) -> Maybe st -> LB st
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Module st -> LB st
forall st. Module st -> LB st
moduleDefState Module st
m) st -> LB st
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe st
savedState
    
    ModuleInfo st
mInfo       <- String -> Module st -> st -> LB (ModuleInfo st)
forall st. String -> Module st -> st -> LB (ModuleInfo st)
registerModule String
mName Module st
m st
mState
    
    (ModuleT st LB () -> ModuleInfo st -> LB ())
-> ModuleInfo st -> ModuleT st LB () -> LB ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleT st LB () -> ModuleInfo st -> LB ()
forall st (m :: * -> *) a. ModuleT st m a -> ModuleInfo st -> m a
runModuleT ModuleInfo st
mInfo (do
            Module st -> ModuleT st LB ()
forall st. Module st -> ModuleT st LB ()
moduleInit Module st
m
            [Command (ModuleT st LB)] -> ModuleT st LB ()
forall st. [Command (ModuleT st LB)] -> ModuleT st LB ()
registerCommands ([Command (ModuleT st LB)] -> ModuleT st LB ())
-> ModuleT st LB [Command (ModuleT st LB)] -> ModuleT st LB ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module st -> ModuleT st LB [Command (ModuleT st LB)]
forall st. Module st -> ModuleT st LB [Command (ModuleT st LB)]
moduleCmds Module st
m)
        LB () -> (SomeException -> LB ()) -> LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \e :: SomeException
e@SomeException{} -> do
            String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (String
"Module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
mName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed to load.  Exception thrown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
            
            String -> LB ()
unregisterModule String
mName
            String -> LB ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Refusing to load due to a broken plugin"

--
-- | Unregister a module's entry in the irc state
--
ircUnloadModule :: String -> LB ()
ircUnloadModule :: String -> LB ()
ircUnloadModule String
mName = do
    String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
infoM (String
"Unloading module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
mName)
    
    String -> LB () -> (forall st. ModuleT st LB ()) -> LB ()
forall a. String -> LB a -> (forall st. ModuleT st LB a) -> LB a
inModuleNamed String
mName (String -> LB ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"module not loaded") ((forall st. ModuleT st LB ()) -> LB ())
-> (forall st. ModuleT st LB ()) -> LB ()
forall a b. (a -> b) -> a -> b
$ do
        Module st
m <- (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
        Bool -> ModuleT st LB () -> ModuleT st LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Module st -> Bool
forall st. Module st -> Bool
moduleSticky Module st
m) (ModuleT st LB () -> ModuleT st LB ())
-> ModuleT st LB () -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleT st LB ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"module is sticky"
        
        Module st -> ModuleT st LB ()
forall st. Module st -> ModuleT st LB ()
moduleExit Module st
m
            ModuleT st LB ()
-> (SomeException -> ModuleT st LB ()) -> ModuleT st LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \e :: SomeException
e@SomeException{} -> 
                String -> ModuleT st LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (String
"Module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
mName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" threw the following exception in moduleExit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
        
        ModuleT st LB ()
forall st. ModuleT st LB ()
writeGlobalState
    
    String -> LB ()
unregisterModule String
mName

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

-- | Checks whether the given user has admin permissions
checkPrivs :: IrcMessage -> LB Bool
checkPrivs :: IrcMessage -> LB Bool
checkPrivs IrcMessage
msg = (IRCRWState -> Bool) -> LB Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Nick -> Set Nick -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (IrcMessage -> Nick
forall a. Message a => a -> Nick
nick IrcMessage
msg) (Set Nick -> Bool)
-> (IRCRWState -> Set Nick) -> IRCRWState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Set Nick
ircPrivilegedUsers)

-- | Checks whether the given user is being ignored.
--   Privileged users can't be ignored.
checkIgnore :: IrcMessage -> LB Bool
checkIgnore :: IrcMessage -> LB Bool
checkIgnore IrcMessage
msg = (Bool -> Bool -> Bool) -> LB Bool -> LB Bool -> LB Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) ((Bool -> Bool) -> LB Bool -> LB Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IrcMessage -> LB Bool
checkPrivs IrcMessage
msg))
                  ((IRCRWState -> Bool) -> LB Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Nick -> Set Nick -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (IrcMessage -> Nick
forall a. Message a => a -> Nick
nick IrcMessage
msg) (Set Nick -> Bool)
-> (IRCRWState -> Set Nick) -> IRCRWState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Set Nick
ircIgnoredUsers))

------------------------------------------------------------------------
-- Some generic server operations

-- Send a CODEPAGE command to set encoding for current session.
-- Some IRC networks don't provide UTF-8 ports, but allow
-- switching it in runtime
ircCodepage :: String -> String -> LB ()
ircCodepage :: String -> String -> LB ()
ircCodepage String
svr String
cpage = do
    IrcMessage -> LB ()
send (IrcMessage -> LB ()) -> IrcMessage -> LB ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IrcMessage
codepage String
svr String
cpage

ircGetChannels :: LB [Nick]
ircGetChannels :: LB [Nick]
ircGetChannels = ((ChanName -> Nick) -> [ChanName] -> [Nick]
forall a b. (a -> b) -> [a] -> [b]
map ChanName -> Nick
getCN ([ChanName] -> [Nick])
-> (Map ChanName String -> [ChanName])
-> Map ChanName String
-> [Nick]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ChanName String -> [ChanName]
forall k a. Map k a -> [k]
M.keys) (Map ChanName String -> [Nick])
-> LB (Map ChanName String) -> LB [Nick]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IRCRWState -> Map ChanName String) -> LB (Map ChanName String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map ChanName String
ircChannels

-- Send a quit message, settle and wait for the server to drop our
-- handle. At which point the main thread gets a closed handle eof
-- exceptoin, we clean up and go home
ircQuit :: String -> String -> LB ()
ircQuit :: String -> String -> LB ()
ircQuit String
svr String
msg = do
    (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' -> IRCRWState
state' { ircPersists :: Map String Bool
ircPersists = String -> Map String Bool -> Map String Bool
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
svr (Map String Bool -> Map String Bool)
-> Map String Bool -> Map String Bool
forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
state' }
    IrcMessage -> LB ()
send  (IrcMessage -> LB ()) -> IrcMessage -> LB ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IrcMessage
quit String
svr String
msg
    IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000
    String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
noticeM String
"Quitting"

ircReconnect :: String -> String -> LB ()
ircReconnect :: String -> String -> LB ()
ircReconnect String
svr String
msg = do
    (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' -> IRCRWState
state' { ircPersists :: Map String Bool
ircPersists = (Bool -> Bool -> Bool)
-> String -> Bool -> Map String Bool -> Map String Bool
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ((Bool -> Bool -> Bool) -> Bool -> Bool -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Bool -> Bool
forall a b. a -> b -> a
const) String
svr Bool
False (Map String Bool -> Map String Bool)
-> Map String Bool -> Map String Bool
forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
state' }
    IrcMessage -> LB ()
send (IrcMessage -> LB ()) -> IrcMessage -> LB ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IrcMessage
quit String
svr String
msg
    IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000

-- | Send a message to a channel\/user, applying all output filters
ircPrivmsg :: Nick      -- ^ The channel\/user.
           -> String        -- ^ The message.
           -> LB ()

ircPrivmsg :: Nick -> String -> LB ()
ircPrivmsg Nick
who String
msg = do
    [String]
sendlines <- Nick -> String -> LB [String]
applyOutputFilters Nick
who String
msg
    Int
w <- Config Int -> LB Int
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Int
textWidth
    (String -> LB ()) -> [String] -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
s -> Nick -> String -> LB ()
ircPrivmsg' Nick
who (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
w String
s)) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
10 [String]
sendlines)

-- A raw send version (bypasses output filters)
ircPrivmsg' :: Nick -> String -> LB ()
ircPrivmsg' :: Nick -> String -> LB ()
ircPrivmsg' Nick
who String
""  = Nick -> String -> LB ()
ircPrivmsg' Nick
who String
" "
ircPrivmsg' Nick
who String
msg = IrcMessage -> LB ()
send (IrcMessage -> LB ()) -> IrcMessage -> LB ()
forall a b. (a -> b) -> a -> b
$ Nick -> String -> IrcMessage
privmsg Nick
who String
msg

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

monadRandom [d|

    instance MonadRandom LB where
        getRandomWord8          = liftIO getRandomWord8
        getRandomWord16         = liftIO getRandomWord16
        getRandomWord32         = liftIO getRandomWord32
        getRandomWord64         = liftIO getRandomWord64
        getRandomDouble         = liftIO getRandomDouble
        getRandomNByteInteger n = liftIO (getRandomNByteInteger n)

 |]