irc-fun-bot-0.6.0.0: src/Network/IRC/Fun/Bot/Internal/Chat.hs
{- This file is part of irc-fun-bot.
-
- Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Network.IRC.Fun.Bot.Internal.Chat
( disconnect
--, reconnect
, quit
, run
, login
, pong
, joinChannel
, joinMulti
, joinConfig
, partChannel
, partMulti
, partAll
, sendIO
, sendToUser
, sendToUser'
, sendToUserNow
, sendToChannel
, sendToChannel'
, sendToChannelNow
, sendBack
, sendBackNow
)
where
import Control.AutoUpdate
import Control.Concurrent.Chan
import Control.Exception (bracket)
import Control.Monad (liftM)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isSpace)
import Data.List (union)
import Data.Text (Text)
import Network.IRC.Fun.Bot.Internal.History (rememberMsg)
import Network.IRC.Fun.Bot.Internal.Monad
import Network.IRC.Fun.Bot.Internal.MsgCount (recordMsg)
import Network.IRC.Fun.Bot.Internal.Persist
import Network.IRC.Fun.Bot.Internal.State
import Network.IRC.Fun.Bot.Internal.Types
import Network.IRC.Fun.Client.ChannelLogger (logEvent, ChanLogEvent (..))
import Network.IRC.Fun.Client.Commands
import Network.IRC.Fun.Client.IO
import Network.IRC.Fun.Client.Time (currentTimeGetter)
import Network.IRC.Fun.Types
import System.Clock
import qualified Data.HashMap.Lazy as M (lookup)
import qualified Data.HashSet as S (toList)
import qualified Data.Text as T
-------------------------------------------------------------------------------
-- Connection Management
-------------------------------------------------------------------------------
-- | Disconnect from IRC by closing the bot's side of the connection. This
-- function is mainly provided for completeness and cases of error. You should
-- probably use the QUIT command of IRC to quit the network in a manner
-- coordinated with the server.
--
-- After disconnection, make sure not to send more IRC commands.
disconnect :: Session e s ()
disconnect = askConnection >>= liftIO . ircDisconnect
-- Disconnect from the IRC server and connect again. This includes
-- identifying with the bot's nickname and joining IRC channels.
--
-- This operation closes the bot session. It opens a new one, and returns it.
--botReconnect :: Session s (Session e s ())
--botReconnect = do
-- disconnect
-- | Finish the IRC session, asking the server to close the connection.
quit :: Maybe Comment -- ^ Optional message, e.g. the reason for quitting
-> Session e s ()
quit reason = do
c <- askConnection
liftIO $ ircQuit c reason
-------------------------------------------------------------------------------
-- Session Management
-------------------------------------------------------------------------------
-- | Connect to an IRC server and run the bot session
run :: Config -- ^ IRC configuration
-> Behavior e s -- ^ Bot behavior definition
-> e -- ^ Custom bot environment (read-only state)
-> s -- ^ Initial custom bot state
-> Session e s a -- ^ Session definition
-> IO a
run conf beh env state session = do
timeGetter <- currentTimeGetter
save <- mkSaveBotState conf
getMin <- mkAutoUpdate defaultUpdateSettings
{ updateFreq = 1000000 * 60 -- 60 seconds
, updateAction = fmap ((`div` 60) . sec) $ getTime Realtime
}
mq <- newChan
putStrLn "Bot: Connecting to IRC server"
bracket
(do ctx <- initConnContext
ircConnect ctx (cfgConnection conf)
)
ircDisconnect
(\ h -> do
let botEnv = BotEnv conf beh h timeGetter getMin save mq env
putStrLn "Bot: Loading state from file"
botState <- loadBotState botEnv state
runSession botEnv botState session
)
-- | Log in as an IRC user and identify with the bot's nickname and password.
-- This is the first thing to do after 'botConnect'ing to the server.
login :: Session e s ()
login = do
c <- askConnection
cfg <- askConfigS cfgConnection
liftIO $ ircLogin c cfg False False
-- | IRC servers send PING messages at regular intervals to test the presence
-- of an active client, at least if no other activity is detected on the
-- connection. The server closes the connection automatically if a PONG
-- response isn't sent from the client within a certain amount of time.
--
-- Therefore, an IRC client (both human users and bots) usually listens to
-- these PINGs and sends back PONG messages. This function sends a PONG. The
-- parameters should simply be the ones received in the PING message.
pong :: Hostname -- ^ Server name
-> Maybe Hostname -- ^ Optional server to forward to
-> Session e s ()
pong server1 mserver2 = do
c <- askConnection
liftIO $ ircPong c server1 mserver2
-------------------------------------------------------------------------------
-- Channels
-------------------------------------------------------------------------------
-- | Join an IRC channel.
joinChannel
:: Channel -- ^ Channel name
-> Maybe ChannelKey -- ^ Optional channel key (password)
-> Session e s ()
joinChannel channel key = do
c <- askConnection
liftIO $ ircJoin c channel key
-- | Join one or more IRC channels.
joinMulti
:: [(Channel, Maybe ChannelKey)] -- ^ List of channels and optional keys
-> Session e s ()
joinMulti channels = do
c <- askConnection
liftIO $ ircJoinMulti c channels
-- | Join the IRC channels listed for joining in the persistent state and in
-- the configuration, without leaving any other channels the bot already
-- joined.
joinConfig :: Session e s ()
joinConfig = do
chansC <- askConfigS cfgChannels
chansP <- liftM S.toList $ gets bsSelChans
let chans = union chansC chansP
joinMulti $ map (flip (,) Nothing) chans
--TODO avoid unnecessary JOINs?
-- | Leave an IRC channel.
partChannel
:: Channel -- ^ Channel name
-> Maybe Comment -- ^ Optional part message, e.g. the reason for leaving
-> Session e s ()
partChannel channel reason = do
c <- askConnection
liftIO $ ircPart c channel reason
removeCurrChan channel
-- | Leave one or more IRC channels.
partMulti
:: [Channel] -- ^ List of channel names
-> Maybe Comment -- ^ Optional part message, e.g. the reason for leaving
-> Session e s ()
partMulti chans reason = do
c <- askConnection
liftIO $ ircPartMulti c chans reason
-- | Leave all IRC channels the bot joined.
partAll :: Session e s ()
partAll = do
askConnection >>= liftIO . ircPartAll
clearCurrChans
-------------------------------------------------------------------------------
-- Sending Messages
-------------------------------------------------------------------------------
-- Split a string into N-sized substrings, dropping surrounding whitespace. The
-- last substring may be shorter than N.
splitN :: Int -> Text -> [Text]
splitN n t =
let (l, r) = T.splitAt n t
in if T.null r
then [l]
else l : splitN n (T.dropWhile isSpace r)
-- Split a message by newlines and possibly length.
makeLines :: MsgContent -> Session e s [MsgContent]
makeLines msg = do
let ls = T.lines $ unMsgContent msg
maybelen <- askConfigS cfgMaxMsgChars
return $ map MsgContent $ case maybelen of
Nothing -> ls
Just maxlen -> concatMap (splitN maxlen) ls
-- Log a channel message event.
logChanMsg :: Nickname -> Channel -> MsgContent -> Session e s ()
logChanMsg nick chan msg = do
cstates <- gets bsChannels
case M.lookup chan cstates >>= csLogger of
Nothing -> return ()
Just lg -> liftIO $ logEvent lg (MessageChan nick msg)
sendC :: Bool -> Connection -> Channel -> MsgContent -> IO ()
sendC True = ircNoticeToChannel
sendC False = ircSendToChannel
sendU :: Bool -> Connection -> Nickname -> MsgContent -> IO ()
sendU True = ircNoticeToUser
sendU False = ircSendToUser
sendToChannelIO :: Connection -> Bool -> Channel -> [MsgContent] -> IO ()
sendToChannelIO c notice chan = mapM_ $ (sendC notice) c chan
sendToUserIO :: Connection -> Bool -> Nickname -> [MsgContent] -> IO ()
sendToUserIO c notice nick = mapM_ $ (sendU notice) c nick
sendIO :: Connection -> IrcMsg -> IO ()
sendIO c msg =
case msgRecip msg of
Left nick -> sendToUserIO c (msgNotice msg) nick $ msgLines msg
Right chan -> sendToChannelIO c (msgNotice msg) chan $ msgLines msg
sendToChannelHere :: Bool -> Channel -> [MsgContent] -> Session e s ()
sendToChannelHere notice chan ls = do
c <- askConnection
liftIO $ sendToChannelIO c notice chan ls
sendToUserHere :: Bool -> Nickname -> [MsgContent] -> Session e s ()
sendToUserHere notice nick ls = do
c <- askConnection
liftIO $ sendToUserIO c notice nick ls
sendToChannelDefer :: Bool -> Channel -> [MsgContent] -> Session e s ()
sendToChannelDefer notice chan ls = do
q <- asks beMsgQueue
let msg = IrcMsg
{ msgRecip = Right chan
, msgLines = ls
, msgNotice = notice
}
liftIO $ writeChan q msg
sendToUserDefer :: Bool -> Nickname -> [MsgContent] -> Session e s ()
sendToUserDefer notice nick ls = do
q <- asks beMsgQueue
let msg = IrcMsg
{ msgRecip = Left nick
, msgLines = ls
, msgNotice = notice
}
liftIO $ writeChan q msg
sendToChannelImpl
:: (Bool -> Channel -> [MsgContent] -> Session e s ())
-> Bool
-> Channel
-> MsgContent
-> Session e s ()
sendToChannelImpl send notice chan msg = do
msgs <- makeLines msg
send notice chan msgs
self <- askConfigS $ connNickname . cfgConnection
let remember s = do
rememberMsg chan self s False
recordMsg chan
logChanMsg self chan s
mapM_ remember msgs
sendToUserImpl
:: (Bool -> Nickname -> [MsgContent] -> Session e s ())
-> Bool
-> Nickname
-> MsgContent
-> Session e s ()
sendToUserImpl send notice nick msg = do
msgs <- makeLines msg
send notice nick msgs
-- | Send a message to an IRC channel.
--
-- This usually requires that the bot joins the channel first, because many
-- channels have the +n flag set. This flag forbids sending a messages into
-- a channel from outside it.
--
-- This function doesn't instantly send the message, but instead queues it for
-- sending by the sending scheduler thread, which adds delay to avoid flood. If
-- you want to send instantly, see 'sendToChannelNow'.
sendToChannel
:: Channel
-- ^ The channel name
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendToChannel = sendToChannel' False
-- | Like 'sendToChannel', but lets you choose whether the message should be a
-- notice.
sendToChannel'
:: Bool
-> Channel
-> MsgContent
-> Session e s ()
sendToChannel' = sendToChannelImpl sendToChannelDefer
-- | A variant of 'sendToChannel' which sends instantly, without any delay.
sendToChannelNow
:: Channel
-- ^ The channel name
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendToChannelNow = sendToChannelImpl sendToChannelHere False
-- | Send a private message to an IRC user.
--
-- This function doesn't instantly send the message, but instead queues it for
-- sending by the sending scheduler thread, which adds delay to avoid flood. If
-- you want to send instantly, see 'sendToUserNow'.
sendToUser
:: Nickname
-- ^ The user's nickname
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendToUser = sendToUser' False
-- | Like 'sendToUser', but lets you choose whether the message should be a
-- notice.
sendToUser'
:: Bool
-> Nickname
-> MsgContent
-> Session e s ()
sendToUser' = sendToUserImpl sendToUserDefer
-- | A variant of 'sendToUser' which sends instantly, without any delay.
sendToUserNow
:: Nickname
-- ^ The user's nickname
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendToUserNow = sendToUserImpl sendToUserHere False
-- | Send a message back to the sender. If a channel is specified, send to the
-- channel. If not, send a private message.
sendBack
:: Maybe Channel
-- ^ Channel name, specify if replying to a message sent in a channel.
-- Otherwise pass 'Nothing'.
-> Nickname
-- ^ The sender user's nickname
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendBack (Just chan) _nick msg = sendToChannel chan msg
sendBack Nothing nick msg = sendToUser nick msg
-- | A variant of 'sendBack' which sends instantly, without any delay.
sendBackNow
:: Maybe Channel
-- ^ Channel name, specify if replying to a message sent in a channel.
-- Otherwise pass 'Nothing'.
-> Nickname
-- ^ The sender user's nickname
-> MsgContent
-- ^ The message to send. It may contain newlines, in which case it will be
-- split into multiple messages and sent sequentially.
-> Session e s ()
sendBackNow (Just chan) _nick msg = sendToChannelNow chan msg
sendBackNow Nothing nick msg = sendToUserNow nick msg
-------------------------------------------------------------------------------
-- Other Utilities
-------------------------------------------------------------------------------
-- See the ChatExt module.