abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Major refactoring

Browse Source 
1. Unified Messages, Events and Commands
2. Switched to a single TChan based message bus for communication between modules
3. Each handler now has a dedicated thread in which it runs, ensuring sequentiality of messages
This commit is contained in:
Abhinav Sarkar 2014-10-04 21:22:24 +05:30
parent e61cab74ed
commit 757285f4fd
25 changed files with 563 additions and 625 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
hask-irc-core/Network/IRC.hs
View File

@ -1,8 +1,15 @@
module Network.IRC {-|
( Module : Network.IRC
module Network.IRC.Types, Description : A simple and extensible IRC bot.
module Network.IRC.Client Copyright : (c) Abhinav Sarkar, 2014
)where License : Apache-2.0
Maintainer : abhinav@abhinavsarkar.net
Stability : experimental
Portability : POSIX
-}
import Network.IRC.Types module Network.IRC (module IRC) where
import Network.IRC.Client
import Network.IRC.Types as IRC
import Network.IRC.Client as IRC
import Network.IRC.MessageBus as IRC

136
hask-irc-core/Network/IRC/Bot.hs
View File

@ -1,22 +1,17 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Bot module Network.IRC.Bot
( Line ( In
, sendCommand
, sendMessage
, sendEvent
, readLine
, sendCommandLoop , sendCommandLoop
, readLineLoop , readMessageLoop
, messageProcessLoop , messageProcessLoop )
, eventProcessLoop )
where where
import qualified Data.Text.Format as TF import qualified Data.Text.Format as TF
import qualified System.Log.Logger as HSL import qualified System.Log.Logger as HSL
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay) import Control.Concurrent.Lifted (threadDelay)
import Control.Exception.Lifted (mask_, mask) import Control.Exception.Lifted (mask_, mask)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.State (get, put) import Control.Monad.State (get, put)
@ -25,145 +20,108 @@ import System.IO (hIsEOF)
import System.Timeout (timeout) import System.Timeout (timeout)
import System.Log.Logger.TH (deriveLoggers) import System.Log.Logger.TH (deriveLoggers)
import Network.IRC.MessageBus
import Network.IRC.Internal.Types import Network.IRC.Internal.Types
import Network.IRC.Protocol import Network.IRC.Protocol
import Network.IRC.Types import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR]) $(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
data Line = Timeout | EOF | Line !UTCTime !Text | Msg FullMessage deriving (Show, Eq) data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
data In = Timeout | EOD | Msg Message deriving (Show, Eq)
sendCommand :: Chan Command -> Command -> IO () sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
sendCommand = writeChan sendCommandLoop commandChan bot@Bot { .. } = do
msg@(Message _ _ cmd) <- receiveMessage commandChan
sendMessage :: Chan Line -> FullMessage -> IO () let mline = formatCommand botConfig msg
sendMessage = (. Msg) . writeChan
sendEvent :: Chan Event -> Event -> IO ()
sendEvent = writeChan
readLine :: Chan Line -> IO Line
readLine = readChan
sendCommandLoop :: Channel Command -> Bot -> IO ()
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
cmd <- readChan commandChan
let mline = formatCommand botConfig cmd
handle (\(e :: SomeException) -> handle (\(e :: SomeException) ->
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do errorM ("Error while writing to connection: " ++ show e) >> closeMessageChannel commandChan) $ do
whenJust mline $ \line -> do whenJust mline $ \line -> do
TF.hprint botSocket "{}\r\n" $ TF.Only line TF.hprint botSocket "{}\r\n" $ TF.Only line
infoM . unpack $ "> " ++ line infoM . unpack $ "> " ++ line
case fromCommand cmd of case fromMessage cmd of
Just QuitCmd -> latchIt latch Just QuitCmd -> closeMessageChannel commandChan
_ -> sendCommandLoop (commandChan, latch) bot _ -> sendCommandLoop commandChan bot
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO () readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
readLineLoop = go [] readMessageLoop = go []
where where
msgPartTimeout = 10 msgPartTimeout = 10
go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do
botStatus <- readMVar mvBotStatus botStatus <- readMVar mvBotStatus
case botStatus of case botStatus of
Disconnected -> latchIt latch Disconnected -> closeMessageChannel inChan
_ -> do _ -> do
mLine <- try $ timeout timeoutDelay readLine' mLine <- try $ timeout timeoutDelay readLine'
msgParts' <- case mLine of msgParts' <- case mLine of
Left (e :: SomeException) -> do Left (e :: SomeException) -> do
errorM $ "Error while reading from connection: " ++ show e errorM $ "Error while reading from connection: " ++ show e
writeChan lineChan EOF >> return msgParts sendMessage inChan EOD >> return msgParts
Right Nothing -> writeChan lineChan Timeout >> return msgParts Right Nothing -> sendMessage inChan Timeout >> return msgParts
Right (Just (Line time line)) -> do Right (Just (Line time line)) -> do
let (mmsg, msgParts') = parseLine botConfig time line msgParts let (mmsg, msgParts') = parseLine botConfig time line msgParts
whenJust mmsg $ writeChan lineChan . Msg whenJust mmsg $ sendMessage inChan . Msg
return msgParts' return msgParts'
Right (Just l) -> writeChan lineChan l >> return msgParts Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
let msgParts'' = concat let msgParts'' = concat
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime)) . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts' . groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay go msgParts'' mvBotStatus inChan bot timeoutDelay
where where
readLine' = do readLine' = do
eof <- hIsEOF botSocket eof <- hIsEOF botSocket
if eof if eof
then return EOF then return EOS
else mask $ \unmask -> do else mask $ \unmask -> do
line <- map initEx . unmask $ hGetLine botSocket line <- map initEx . unmask $ hGetLine botSocket
infoM . unpack $ "< " ++ line infoM . unpack $ "< " ++ line
now <- getCurrentTime now <- getCurrentTime
return $ Line now line return $ Line now line
messageProcessLoop :: Chan Line -> Chan Command -> IRC () messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
messageProcessLoop = go 0 messageProcessLoop = go 0
where where
go !idleFor lineChan commandChan = do go !idleFor inChan messageChan = do
status <- get status <- get
bot@Bot { .. } <- ask Bot { .. } <- ask
let nick = botNick botConfig let nick = botNick botConfig
nStatus <- io . mask_ $ nStatus <- io . mask_ $
if idleFor >= (oneSec * botTimeout botConfig) if idleFor >= (oneSec * botTimeout botConfig)
then infoM "Timeout" >> return Disconnected then infoM "Timeout" >> return Disconnected
else do else do
when (status == Kicked) $ when (status == Kicked) $
threadDelay (5 * oneSec) >> sendCommand commandChan (toCommand JoinCmd) threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
mLine <- readLine lineChan mIn <- receiveMessage inChan
case mLine of case mIn of
Timeout -> do Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
now <- getCurrentTime EOD -> infoM "Connection closed" >> return Disconnected
dispatchHandlers bot (FullMessage now "" $ toMessage IdleMsg) >> return Idle Msg (msg@Message { .. }) -> do
EOF -> infoM "Connection closed" >> return Disconnected
Line _ _ -> error "This should never happen"
Msg (msg@FullMessage { .. }) -> do
nStatus <- handleMsg nick message nStatus <- handleMsg nick message
dispatchHandlers bot msg sendMessage messageChan msg
return nStatus return nStatus
put nStatus put nStatus
case nStatus of case nStatus of
Idle -> go (idleFor + oneSec) lineChan commandChan Idle -> go (idleFor + oneSec) inChan messageChan
Disconnected -> return () Disconnected -> return ()
NickNotAvailable -> return () NickNotAvailable -> return ()
_ -> go 0 lineChan commandChan _ -> go 0 inChan messageChan
where where
dispatchHandlers Bot { .. } message =
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
handle (\(e :: SomeException) ->
errorM $ "Exception while processing message: " ++ show e) $ do
cmds <- handleMessage msgHandler botConfig message
forM_ cmds (sendCommand commandChan)
handleMsg nick message handleMsg nick message
| Just (JoinMsg user) <- fromMessage message, userNick user == nick = | Just (JoinMsg user) <- fromMessage message, userNick user == nick =
infoM "Joined" >> return Joined infoM "Joined" >> return Joined
| Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick = | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
infoM "Kicked" >> return Kicked infoM "Kicked" >> return Kicked
| Just NickInUseMsg <- fromMessage message = | Just NickInUseMsg <- fromMessage message =
infoM "Nick already in use" >> return NickNotAvailable infoM "Nick already in use" >> return NickNotAvailable
| Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self = | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self =
sendCommand commandChan (toCommand JoinCmd) >> return Connected newMessage JoinCmd >>= sendMessage messageChan >> return Connected
| otherwise = return Connected | otherwise =
return Connected
eventProcessLoop :: Channel Event -> Chan Line -> Chan Command -> Bot -> IO ()
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
event <- readChan eventChan
case fromEvent event of
Just (QuitEvent, _) -> latchIt latch
_ -> do
debugM $ "Event: " ++ show event
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
handle (\(ex :: SomeException) ->
errorM $ "Exception while processing event: " ++ show ex) $ do
resp <- handleEvent msgHandler botConfig event
case resp of
RespMessage messages -> forM_ messages $ sendMessage lineChan
RespCommand commands -> forM_ commands $ sendCommand commandChan
RespEvent events -> forM_ events $ sendEvent eventChan
_ -> return ()
eventProcessLoop (eventChan, latch) lineChan commandChan bot

133
hask-irc-core/Network/IRC/Client.hs
View File

@ -15,7 +15,7 @@ module Network.IRC.Client (runBot) where
import qualified System.Log.Logger as HSL import qualified System.Log.Logger as HSL
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan) import Control.Concurrent.Lifted (fork, threadDelay, myThreadId)
import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt)) import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
import Network (PortID (PortNumber), connectTo, withSocketsDo) import Network (PortID (PortNumber), connectTo, withSocketsDo)
import System.IO (hSetBuffering, BufferMode(..)) import System.IO (hSetBuffering, BufferMode(..))
@ -27,93 +27,103 @@ import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerN
import System.Log.Logger.TH (deriveLoggers) import System.Log.Logger.TH (deriveLoggers)
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
import qualified Network.IRC.Handlers.Core as Core
import Network.IRC.Bot import Network.IRC.Bot
import Network.IRC.Internal.Types import Network.IRC.Internal.Types
import Network.IRC.MessageBus
import Network.IRC.Types import Network.IRC.Types
import Network.IRC.Handlers.Core
import Network.IRC.Util import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
coreMsgHandlerNames :: [MsgHandlerName] data ConnectionResource = ConnectionResource
coreMsgHandlerNames = ["pingpong", "help"] { bot :: Bot
, botStatus :: MVar BotStatus
, inChannel :: MessageChannel In
, mainMsgChannel :: MessageChannel Message
, cmdMsgChannel :: MessageChannel Message
, handlerMsgChannels :: [MessageChannel Message]
}
connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) connect :: BotConfig -> IO ConnectionResource
connect botConfig@BotConfig { .. } = do connect botConfig@BotConfig { .. } = do
debugM "Connecting ..." debugM "Connecting ..."
socket <- connectToWithRetry socket <- connectToWithRetry
hSetBuffering socket LineBuffering hSetBuffering socket LineBuffering
debugM "Connected" debugM "Connected"
lineChan <- newChannel messageBus <- newMessageBus
commandChan <- newChannel inBus <- newMessageBus
eventChan <- newChannel mvBotStatus <- newMVar Connected
mvBotStatus <- newMVar Connected
msgHandlers <- loadMsgHandlers (fst eventChan) inChannel <- newMessageChannel inBus
msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m) mainMsgChannel <- newMessageChannel messageBus
mempty (mapToList msgHandlers) cmdMsgChannel <- newMessageChannel messageBus
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan) msgHandlersChans <- loadMsgHandlers messageBus
msgHandlerInfo' <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
mempty (mapToList msgHandlersChans)
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
let msgHandlerChannels = map snd (mapValues msgHandlersChans)
let msgHandlers = map fst msgHandlersChans
return $ ConnectionResource
(Bot botConfig' socket msgHandlers) mvBotStatus
inChannel mainMsgChannel cmdMsgChannel msgHandlerChannels
where where
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port)) connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
`catch` (\(e :: SomeException) -> do `catch` (\(e :: SomeException) -> do
errorM ("Error while connecting: " ++ show e ++ ". Waiting.") errorM ("Error while connecting: " ++ show e ++ ". Waiting.")
threadDelay (5 * oneSec) threadDelay (5 * oneSec)
connectToWithRetry) connectToWithRetry)
newChannel = (,) <$> newChan <*> newEmptyMVar mkMsgHandler name messageBus =
case lookup name msgHandlerMakers of
Nothing -> return Nothing
Just maker -> do
messageChannel <- newMessageChannel messageBus
handler <- msgHandlerMaker maker botConfig messageChannel
return $ Just (handler, messageChannel)
mkMsgHandler :: Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler) loadMsgHandlers messageBus =
mkMsgHandler eventChan name =
flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
case finalHandler of
Just _ -> return finalHandler
Nothing -> msgHandlerMaker handler botConfig eventChan name
loadMsgHandlers eventChan =
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
debugM . unpack $ "Loading msg handler: " ++ msgHandlerName debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
mMsgHandler <- mkMsgHandler eventChan msgHandlerName mMsgHandler <- mkMsgHandler msgHandlerName messageBus
case mMsgHandler of case mMsgHandler of
Nothing -> do Nothing -> do
debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
return hMap return hMap
Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap
disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) -> IO () disconnect :: ConnectionResource -> IO ()
disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do disconnect ConnectionResource { bot = Bot { .. }, .. } = do
debugM "Disconnecting ..." debugM "Disconnecting ..."
sendCommand commandChan $ toCommand QuitCmd sendMessage cmdMsgChannel =<< newMessage QuitCmd
awaitLatch sendLatch awaitMessageChannel cmdMsgChannel
swapMVar mvBotStatus Disconnected
awaitLatch readLatch
sendEvent eventChan =<< toEvent QuitEvent
awaitLatch eventLatch
unloadMsgHandlers swapMVar botStatus Disconnected
awaitMessageChannel inChannel
forM_ handlerMsgChannels awaitMessageChannel
handle (\(_ :: SomeException) -> return ()) $ hClose botSocket handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
debugM "Disconnected" debugM "Disconnected"
where
unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
stopMsgHandler msgHandler botConfig
runBotIntenal :: BotConfig -> IO () runBotIntenal :: BotConfig -> IO ()
runBotIntenal botConfig' = withSocketsDo $ do runBotIntenal botConfig' = withSocketsDo $ do
status <- run status <- run
case status of case status of
Disconnected -> debugM "Restarting .." >> runBotIntenal botConfig Disconnected -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
Errored -> debugM "Restarting .." >> runBotIntenal botConfig Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
Interrupted -> return () Interrupted -> return ()
NickNotAvailable -> return () NickNotAvailable -> return ()
_ -> error "Unsupported status" _ -> error "Unsupported status"
where where
botConfig = botConfig' { botConfigWithCore = botConfig' {
msgHandlerInfo = msgHandlerInfo =
foldl' (\m name -> insertMap name mempty m) mempty foldl' (\m name -> insertMap name mempty m) mempty
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames), (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers),
msgHandlerMakers = ordNub $ Core.mkMsgHandler : msgHandlerMakers botConfig' msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
} }
handleErrors :: SomeException -> IO BotStatus handleErrors :: SomeException -> IO BotStatus
@ -121,18 +131,33 @@ runBotIntenal botConfig' = withSocketsDo $ do
Just UserInterrupt -> debugM "User interrupt" >> return Interrupted Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
_ -> debugM ("Exception! " ++ show e) >> return Errored _ -> debugM ("Exception! " ++ show e) >> return Errored
run = bracket (connect botConfig) disconnect $ runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) -> where
go msg@Message { .. }
| Just QuitCmd <- fromMessage message = do
debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
stopMsgHandler handler botConfig
closeMessageChannel msgChannel
return ()
| otherwise = do
resps <- handleMessage handler botConfig msg
forM_ resps $ sendMessage msgChannel
runHandler botConfig ((msgHandlerName, handler), msgChannel)
run = bracket (connect botConfigWithCore) disconnect $
\ConnectionResource { .. } ->
handle handleErrors $ do handle handleErrors $ do
let Bot { .. } = bot
debugM $ "Running with config:\n" ++ show botConfig debugM $ "Running with config:\n" ++ show botConfig
sendCommand commandChan $ toCommand NickCmd sendMessage cmdMsgChannel =<< newMessage NickCmd
sendCommand commandChan $ toCommand UserCmd sendMessage cmdMsgChannel =<< newMessage UserCmd
fork $ sendCommandLoop (commandChan, sendLatch) bot fork $ sendCommandLoop cmdMsgChannel bot
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec fork $ readMessageLoop botStatus inChannel bot oneSec
fork $ eventProcessLoop eventChannel lineChan commandChan bot forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $
runIRC bot Connected (messageProcessLoop lineChan commandChan) void . fork . runHandler botConfig
runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)
-- | Creates and runs an IRC bot for given the config. This IO action runs forever. -- | Creates and runs an IRC bot for given the config. This IO action runs forever.
runBot :: BotConfig -- ^ The bot config used to create the bot. runBot :: BotConfig -- ^ The bot config used to create the bot.

60
hask-irc-core/Network/IRC/Handlers/Core.hs
View File

@ -1,50 +1,57 @@
module Network.IRC.Handlers.Core (mkMsgHandler) where module Network.IRC.Handlers.Core (coreMsgHandlerMakers) where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Data.Convertible (convert) import Data.Convertible (convert)
import Data.Time (addUTCTime) import Data.Time (addUTCTime)
import Network.IRC.Types import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
mkMsgHandler :: MsgHandlerMaker coreMsgHandlerMakers :: Map MsgHandlerName MsgHandlerMaker
mkMsgHandler = MsgHandlerMaker "core" go coreMsgHandlerMakers = mapFromList [
where ("pingpong", pingPongMsgHandlerMaker)
go _ _ "pingpong" = do , ("help", helpMsgHandlerMaker)
state <- getCurrentTime >>= newIORef ]
return . Just $ newMsgHandler { onMessage = pingPong state }
go _ _ "help" =
return . Just $ newMsgHandler { onMessage = help,
onHelp = return $ singletonMap "!help" helpMsg }
go _ _ _ = return Nothing
pingPongMsgHandlerMaker :: MsgHandlerMaker
pingPongMsgHandlerMaker = MsgHandlerMaker "pingpong" go
where
go _ _ = do
state <- io $ getCurrentTime >>= newIORef
return $ newMsgHandler { onMessage = pingPong state }
helpMsgHandlerMaker :: MsgHandlerMaker
helpMsgHandlerMaker = MsgHandlerMaker "help" go
where
go _ _ = return $ newMsgHandler { onMessage = help
, handlerHelp = return $ singletonMap "!help" helpMsg }
helpMsg = "Get help. !help or !help <command>" helpMsg = "Get help. !help or !help <command>"
pingPong :: MonadMsgHandler m => IORef UTCTime -> FullMessage -> m [Command] pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message]
pingPong state FullMessage { .. } pingPong state Message { .. }
| Just (PingMsg msg) <- fromMessage message = | Just (PingMsg msg) <- fromMessage message =
io (atomicWriteIORef state msgTime) >> return [toCommand $ PongCmd msg] io (atomicWriteIORef state msgTime) >> map singleton (newMessage . PongCmd $ msg)
| Just (PongMsg _) <- fromMessage message = | Just (PongMsg _) <- fromMessage message =
io (atomicWriteIORef state msgTime) >> return [] io (atomicWriteIORef state msgTime) >> return []
| Just IdleMsg <- fromMessage message | Just IdleMsg <- fromMessage message
, even (convert msgTime :: Int) = do , even (convert msgTime :: Int) = do
BotConfig { .. } <- ask BotConfig { .. } <- ask
let limit = fromIntegral $ botTimeout `div` 2 let limit = fromIntegral $ botTimeout `div` 2
io $ do lastComm <- io $ readIORef state
lastComm <- readIORef state if addUTCTime limit lastComm < msgTime
return [toCommand . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime then map singleton . newMessage . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
| addUTCTime limit lastComm < msgTime] else return []
| otherwise = return [] | otherwise = return []
help :: MonadMsgHandler m => FullMessage -> m [Command] help :: MonadMsgHandler m => Message -> m [Message]
help FullMessage { .. } = case fromMessage message of help Message { .. } = case fromMessage message of
Just (ChannelMsg _ msg) Just (ChannelMsg _ msg)
| "!help" == clean msg -> do | "!help" == clean msg -> do
BotConfig { .. } <- ask BotConfig { .. } <- ask
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
return . map (toCommand . ChannelMsgReply) $ mapM (newMessage . ChannelMsgReply) [
[ "I know these commands: " ++ unwords commands "I know these commands: " ++ unwords commands
, "Type !help <command> to know more about any command" , "Type !help <command> to know more about any command"
] ]
| "!help" `isPrefixOf` msg -> do | "!help" `isPrefixOf` msg -> do
@ -52,5 +59,6 @@ help FullMessage { .. } = case fromMessage message of
let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
let mHelp = find ((\c -> c == command || c == cons '!' command) . fst) let mHelp = find ((\c -> c == command || c == cons '!' command) . fst)
. concatMap mapToList . mapValues $ msgHandlerInfo . concatMap mapToList . mapValues $ msgHandlerInfo
return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp] map singleton . newMessage . ChannelMsgReply
$ maybe ("No such command found: " ++ command) snd mHelp
_ -> return [] _ -> return []

67
hask-irc-core/Network/IRC/Internal/Command/Types.hs
View File

@ -1,67 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.Internal.Command.Types where
import ClassyPrelude
import Data.Typeable (cast)
import Network.IRC.Internal.Message.Types
-- | The typeclass for IRC commands sent from the bot to the server.
class (Typeable cmd, Show cmd, Eq cmd, Ord cmd) => CommandC cmd where
toCommand :: cmd -> Command
toCommand = Command
fromCommand :: Command -> Maybe cmd
fromCommand (Command cmd) = cast cmd
-- | A wrapper over all types of IRC commands.
data Command = forall m . CommandC m => Command m deriving (Typeable)
instance Show Command where
show (Command m) = show m
instance Eq Command where
Command m1 == Command m2 = case cast m1 of
Just m1' -> m1' == m2
_ -> False
-- | A /PING/ command. A 'PongMsg' is expected as a response to this.
data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
instance CommandC PingCmd
-- | A /PONG/ command. Sent in response to a 'PingMsg'.
data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
instance CommandC PongCmd
-- | A /PRIVMSG/ message sent to the channel.
data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
instance CommandC ChannelMsgReply
-- | A /PRIVMSG/ message sent to a user.
data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
instance CommandC PrivMsgReply
-- | A /NICK/ command sent to set the bot's nick.
data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord)
instance CommandC NickCmd
-- | A /USER/ command sent to identify the bot.
data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord)
instance CommandC UserCmd
-- | A /JOIN/ command sent to join the channel.
data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord)
instance CommandC JoinCmd
-- | A /QUIT/ command sent to quit the server.
data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord)
instance CommandC QuitCmd
-- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord)
instance CommandC NamesCmd

57
hask-irc-core/Network/IRC/Internal/Event/Types.hs
View File

@ -1,57 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.Internal.Event.Types where
import ClassyPrelude
import Data.Typeable (cast)
import Network.IRC.Internal.Message.Types
import Network.IRC.Internal.Command.Types
-- ** Events
-- | Events are used for communication between message handlers. To send events, write them to the
-- event channel provided to the 'MsgHandler' when it is created. To receive events, provide
-- an 'onEvent' function as a part of the message handler.
class (Typeable e, Show e, Eq e) => EventC e where
-- | Creates an event.
toEvent :: e -> IO Event
toEvent e = Event <$> pure e <*> getCurrentTime
-- | Extracts a received event.
fromEvent :: Event -> Maybe (e, UTCTime)
fromEvent (Event e time) = do
ev <- cast e
return (ev, time)
-- | A wrapper over all types of 'Event's to allow sending them over channel of same type.
data Event = forall e. (EventC e, Typeable e) => Event e UTCTime deriving (Typeable)
instance Show Event where
show (Event e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
instance Eq Event where
Event e1 t1 == Event e2 t2 =
case cast e2 of
Just e2' -> e1 == e2' && t1 == t2
Nothing -> False
-- | Response to an event received by a message handler.
data EventResponse =
-- | No response
RespNothing
-- | Events as the response. They will be sent to all message handlers like usual events.
| RespEvent [Event]
-- | Messages as the response. They will be sent to all message handlers like usual messages.
| RespMessage [FullMessage]
-- | Commands as the response. They will be sent to the server like usual commands.
| RespCommand [Command]
deriving (Show, Eq)
-- | An event signifying the bot quitting the server.
data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable)
instance EventC QuitEvent

115
hask-irc-core/Network/IRC/Internal/Types.hs
View File

@ -8,15 +8,13 @@ module Network.IRC.Internal.Types where
import qualified Data.Configurator as CF import qualified Data.Configurator as CF
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (Chan) import Control.Monad.Base (MonadBase)
import Control.Monad.Base (MonadBase) import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) import Control.Monad.State (StateT, MonadState, execStateT)
import Control.Monad.State (StateT, MonadState, execStateT) import Data.Configurator.Types (Config)
import Data.Configurator.Types (Config)
import Network.IRC.Internal.Command.Types import Network.IRC.Message.Types
import Network.IRC.Internal.Event.Types import Network.IRC.MessageBus
import Network.IRC.Internal.Message.Types
import Network.IRC.Util import Network.IRC.Util
-- ** Message Parsing -- ** Message Parsing
@ -25,17 +23,17 @@ import Network.IRC.Util
type MessageParserId = Text type MessageParserId = Text
-- | A part of a mutlipart message. -- | A part of a mutlipart message.
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
, msgPartTarget :: !Text , msgPartTarget :: !Text
, msgPartTime :: !UTCTime , msgPartTime :: !UTCTime
, msgPartLine :: !Text , msgPartLine :: !Text
} deriving (Eq, Show) } deriving (Eq, Show)
-- | The result of parsing a message line. -- | The result of parsing a message line.
data MessageParseResult = data MessageParseResult =
Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts. Done !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts.
| Partial ![MessagePart] -- ^ A partial message with message parts received yet. | Partial ![MessagePart] -- ^ A partial message with message parts received yet.
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser. | Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
deriving (Eq, Show) deriving (Eq, Show)
-- | A message parser used for parsing text lines from the server to 'Message's. -- | A message parser used for parsing text lines from the server to 'Message's.
@ -47,7 +45,7 @@ data MessageParser = MessageParser
-- ** Command Formatting -- ** Command Formatting
-- | A command formatter which optinally formats commands to texts which are then send to the server. -- | A command formatter which optinally formats commands to texts which are then send to the server.
type CommandFormatter = BotConfig -> Command -> Maybe Text type CommandFormatter = BotConfig -> Message -> Maybe Text
-- ** Bot -- ** Bot
@ -58,11 +56,11 @@ type MsgHandlerName = Text
data BotConfig = BotConfig data BotConfig = BotConfig
{ {
-- | The server to connect to. -- | The server to connect to.
server :: !Text botServer :: !Text
-- | The port to connect to. -- | The port to connect to.
, port :: !Int , botPort :: !Int
-- | The channel to join. -- | The channel to join.
, channel :: !Text , botChannel :: !Text
-- | Nick of the bot. -- | Nick of the bot.
, botNick :: !Nick , botNick :: !Nick
-- | The timeout in seconds after which bot automatically disconnects and tries to reconnect. -- | The timeout in seconds after which bot automatically disconnects and tries to reconnect.
@ -72,7 +70,7 @@ data BotConfig = BotConfig
-- by that message handler to the help text of that command. -- by that message handler to the help text of that command.
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
-- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot. -- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot.
, msgHandlerMakers :: ![MsgHandlerMaker] , msgHandlerMakers :: !(Map MsgHandlerName MsgHandlerMaker)
-- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones. -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
, msgParsers :: ![MessageParser] , msgParsers :: ![MessageParser]
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones. -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
@ -82,22 +80,23 @@ data BotConfig = BotConfig
} }
instance Show BotConfig where instance Show BotConfig where
show BotConfig { .. } = "BotConfig[ server = " ++ show server ++ "\n" ++ show BotConfig { .. } = "BotConfig {" ++ "\n" ++
"port = " ++ show port ++ "\n" ++ "server = " ++ show botServer ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++ "port = " ++ show botPort ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++ "channel = " ++ show botChannel ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++ "nick = " ++ show botNick ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]" "timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }"
-- | Creates a new bot config with essential fields leaving rest fields empty. -- | Creates a new bot config with essential fields leaving rest fields empty.
newBotConfig :: Text -- ^ server newBotConfig :: Text -- ^ server
-> Int -- ^ port -> Int -- ^ port
-> Text -- ^ channel -> Text -- ^ channel
-> Nick -- ^ botNick -> Nick -- ^ botNick
-> Int -- ^ botTimeout -> Int -- ^ botTimeout
-> BotConfig -> BotConfig
newBotConfig server port channel botNick botTimeout = newBotConfig server port channel botNick botTimeout =
BotConfig server port channel botNick botTimeout mempty [] [] [] CF.empty BotConfig server port channel botNick botTimeout mempty mempty [] [] CF.empty
-- | The bot. -- | The bot.
data Bot = Bot data Bot = Bot
@ -111,15 +110,15 @@ data Bot = Bot
} }
-- | The current status of the bot. -- | The current status of the bot.
data BotStatus = Connected -- ^ Connected to the server data BotStatus = Connected -- ^ Connected to the server
| Disconnected -- ^ Disconnected from the server. | Disconnected -- ^ Disconnected from the server.
| Joined -- ^ Joined the channel. | Joined -- ^ Joined the channel.
| Kicked -- ^ Kicked from the channel. | Kicked -- ^ Kicked from the channel.
| Errored -- ^ Some unhandled error happened. | Errored -- ^ Some unhandled error happened.
| Idle -- ^ No communication with the server. The bot is idle. | Idle -- ^ No communication with the server. The bot is idle.
-- If the bot stays idle for 'botTimeout' seconds, it disconnects. -- If the bot stays idle for 'botTimeout' seconds, it disconnects.
| Interrupted -- ^ Interrupted using external signals like SIGINT. | Interrupted -- ^ Interrupted using external signals like SIGINT.
| NickNotAvailable -- ^ Bot's nick already taken on the server. | NickNotAvailable -- ^ Bot's nick already taken on the server.
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
-- | An IRC action to be run. -- | An IRC action to be run.
@ -162,23 +161,21 @@ data MsgHandler = MsgHandler
{ {
-- | The action invoked when a message is received. It returns a list of commands in response -- | The action invoked when a message is received. It returns a list of commands in response
-- to the message which the bot sends to the server. -- to the message which the bot sends to the server.
onMessage :: !(forall m . MonadMsgHandler m => FullMessage -> m [Command]) onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message])
-- | The action invoked when an event is triggered. It returns an event resonpse which the bot
-- handles according to its type.
, onEvent :: !(forall m . MonadMsgHandler m => Event -> m EventResponse)
-- | The action invoked to stop the message handler. -- | The action invoked to stop the message handler.
, onStop :: !(forall m . MonadMsgHandler m => m ()) , onStop :: !(forall m . MonadMsgHandler m => m ())
-- | The action invoked to get the map of the commands supported by the message handler and their help messages. -- | The action invoked to get the map of the commands supported by the message handler and their help messages.
, onHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text)) , handlerHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text))
} }
-- | Creates a new message handler which doesn't do anything. -- | Creates a new message handler which doesn't do anything.
newMsgHandler :: MsgHandler newMsgHandler :: MsgHandler
newMsgHandler = MsgHandler newMsgHandler = MsgHandler
{ onMessage = const $ return [] { onMessage = const $ return mempty
, onStop = return () , onStop = return ()
, onEvent = const $ return RespNothing , handlerHelp = return mempty
, onHelp = return mempty
} }
-- | A message handler maker which creates a new message handler. -- | A message handler maker which creates a new message handler.
@ -187,7 +184,7 @@ data MsgHandlerMaker = MsgHandlerMaker
-- | The name of the message handler. -- | The name of the message handler.
msgHandlerName :: !MsgHandlerName msgHandlerName :: !MsgHandlerName
-- | The action which is invoked to create a new message handler. -- | The action which is invoked to create a new message handler.
, msgHandlerMaker :: !(BotConfig -> Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler)) , msgHandlerMaker :: !(BotConfig -> MessageChannel Message -> IO MsgHandler)
} }
instance Eq MsgHandlerMaker where instance Eq MsgHandlerMaker where
@ -198,19 +195,11 @@ instance Ord MsgHandlerMaker where
-- | Handles a message using a given message handler. -- | Handles a message using a given message handler.
handleMessage :: MsgHandler -- ^ The message handler. handleMessage :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config. -> BotConfig -- ^ The bot config.
-> FullMessage -- ^ The message to handle. -> Message -- ^ The message to handle.
-> IO [Command] -- ^ A list of commands to be sent to the server. -> IO [Message] -- ^ A list of commands to be sent to the server.
handleMessage MsgHandler { .. } botConfig = handleMessage MsgHandler { .. } botConfig =
flip runReaderT botConfig . _runMsgHandler . onMessage flip runReaderT botConfig . _runMsgHandler . onMessage
-- | Handles an event using a given message handler.
handleEvent :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config.
-> Event -- ^ The event to handle.
-> IO EventResponse -- ^ The event response which will be dispatched by the bot.
handleEvent MsgHandler { .. } botConfig =
flip runReaderT botConfig . _runMsgHandler . onEvent
-- | Stops a message handler. -- | Stops a message handler.
stopMsgHandler :: MsgHandler -- ^ The message handler. stopMsgHandler :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config. -> BotConfig -- ^ The bot config.
@ -223,4 +212,4 @@ getHelp :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config. -> BotConfig -- ^ The bot config.
-> IO (Map Text Text) -- ^ A map of the commands supported by this message handler to their help messages. -> IO (Map Text Text) -- ^ A map of the commands supported by this message handler to their help messages.
getHelp MsgHandler { .. } botConfig = getHelp MsgHandler { .. } botConfig =
flip runReaderT botConfig . _runMsgHandler $ onHelp flip runReaderT botConfig . _runMsgHandler $ handlerHelp

75
hask-irc-core/Network/IRC/Internal/Message/Types.hs → hask-irc-core/Network/IRC/Message/Types.hs
View File

@ -4,15 +4,14 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.IRC.Internal.Message.Types where module Network.IRC.Message.Types where
import ClassyPrelude import ClassyPrelude
import Data.Data (Data) import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy) import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast) import Data.Typeable (cast)
-- ** IRC Message
-- | An IRC nick. -- | An IRC nick.
newtype Nick = Nick { nickToText :: Text } newtype Nick = Nick { nickToText :: Text }
@ -34,31 +33,36 @@ data User
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
-- | An IRC message sent from the server to the bot. -- | An IRC message sent from the server to the bot.
data FullMessage = FullMessage data Message = Message
{ msgTime :: !UTCTime -- ^ The time when the message was received. { msgTime :: !UTCTime -- ^ The time when the message was received.
, msgLine :: !Text -- ^ The raw message line. , msgLine :: !Text -- ^ The raw message line.
, message :: Message -- ^ The details of the parsed message. , message :: MessageW -- ^ The details of the parsed message.
} deriving (Show, Eq) } deriving (Show, Eq)
-- | The typeclass for different types of IRC messages. -- | The typeclass for different types of IRC messages.
class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
toMessage :: msg -> Message toMessage :: msg -> MessageW
toMessage = Message toMessage = MessageW
fromMessage :: Message -> Maybe msg fromMessage :: MessageW -> Maybe msg
fromMessage (Message msg) = cast msg fromMessage (MessageW msg) = cast msg
-- | A wrapper over all types of IRC messages. -- | A wrapper over all types of IRC messages.
data Message = forall m . MessageC m => Message m deriving (Typeable) data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
instance Show Message where instance Show MessageW where
show (Message m) = show m show (MessageW m) = show m
instance Eq Message where instance Eq MessageW where
Message m1 == Message m2 = case cast m1 of MessageW m1 == MessageW m2 = case cast m1 of
Just m1' -> m1' == m2 Just m1' -> m1' == m2
_ -> False _ -> False
newMessage :: (MessageC msg, MonadIO m) => msg -> m Message
newMessage msg = do
t <- liftIO getCurrentTime
return $ Message t "" (toMessage msg)
-- | The internal (non-IRC) message received when the bot is idle. -- | The internal (non-IRC) message received when the bot is idle.
data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord) data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord)
instance MessageC IdleMsg instance MessageC IdleMsg
@ -121,3 +125,40 @@ instance MessageC ModeMsg
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text } data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
deriving (Typeable, Show, Eq, Ord) deriving (Typeable, Show, Eq, Ord)
instance MessageC OtherMsg instance MessageC OtherMsg
-- | A /PING/ command. A 'PongMsg' is expected as a response to this.
data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
instance MessageC PingCmd
-- | A /PONG/ command. Sent in response to a 'PingMsg'.
data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
instance MessageC PongCmd
-- | A /PRIVMSG/ message sent to the channel.
data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
instance MessageC ChannelMsgReply
-- | A /PRIVMSG/ message sent to a user.
data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
instance MessageC PrivMsgReply
-- | A /NICK/ command sent to set the bot's nick.
data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord)
instance MessageC NickCmd
-- | A /USER/ command sent to identify the bot.
data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord)
instance MessageC UserCmd
-- | A /JOIN/ command sent to join the channel.
data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord)
instance MessageC JoinCmd
-- | A /QUIT/ command sent to quit the server.
data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord)
instance MessageC QuitCmd
-- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord)
instance MessageC NamesCmd

58
hask-irc-core/Network/IRC/MessageBus.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Network.IRC.MessageBus
( MessageBus
, newMessageBus
, MessageChannel
, newMessageChannel
, sendMessage
, receiveMessage
, closeMessageChannel
, awaitMessageChannel ) where
import ClassyPrelude
newtype Latch = Latch (MVar ())
newLatch :: IO Latch
newLatch = liftM Latch newEmptyMVar
doLatch :: Latch -> IO ()
doLatch (Latch mv) = putMVar mv ()
awaitLatch :: Latch -> IO ()
awaitLatch (Latch mv) = void $ takeMVar mv
newtype MessageBus a = MessageBus (TChan a)
newMessageBus :: IO (MessageBus a)
newMessageBus = MessageBus <$> newBroadcastTChanIO
data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
newMessageChannel ::MessageBus a -> IO (MessageChannel a)
newMessageChannel (MessageBus wChan) = do
latch <- newLatch
rChan <- atomically $ dupTChan wChan
return $ MessageChannel latch rChan wChan
sendMessageSTM :: MessageChannel a -> a -> STM ()
sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
receiveMessageSTM :: MessageChannel a -> STM a
receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan
sendMessage :: MessageChannel a -> a -> IO ()
sendMessage chan = atomically . sendMessageSTM chan
receiveMessage :: MessageChannel a -> IO a
receiveMessage = atomically . receiveMessageSTM
closeMessageChannel :: MessageChannel a -> IO ()
closeMessageChannel (MessageChannel latch _ _) = doLatch latch
awaitMessageChannel :: MessageChannel a -> IO ()
awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch

44
hask-irc-core/Network/IRC/Protocol.hs
View File

@ -10,7 +10,7 @@ import Data.Text (strip)
import Network.IRC.Types import Network.IRC.Types
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart]) parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
parseLine botConfig@BotConfig { .. } time line msgParts = parseLine botConfig@BotConfig { .. } time line msgParts =
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } -> fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } ->
let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
@ -25,7 +25,7 @@ pingParser :: MessageParser
pingParser = MessageParser "ping" go pingParser = MessageParser "ping" go
where where
go _ time line _ go _ time line _
| "PING :" `isPrefixOf` line = Done (FullMessage time line . toMessage . PingMsg . drop 6 $ line) [] | "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) []
| otherwise = Reject | otherwise = Reject
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text) parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
@ -47,17 +47,17 @@ lineParser = MessageParser "line" go
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage "QUIT" -> done $ toMessage $ QuitMsg user quitMessage
"PART" -> done $ toMessage $ PartMsg user message "PART" -> done $ toMessage $ PartMsg user message
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason "KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
"MODE" -> done $ toMessage $ if Nick source == botNick "MODE" -> done $ toMessage $ if Nick target == botNick
then ModeMsg Self target message [] then ModeMsg Self target message []
else ModeMsg user target mode modeArgs else ModeMsg user target mode modeArgs
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target) "NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
"433" -> done $ toMessage NickInUseMsg "433" -> done $ toMessage NickInUseMsg
"PRIVMSG" | target /= channel -> done $ toMessage $ PrivMsg user message "PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message) | isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> done $ toMessage $ ChannelMsg user message | otherwise -> done $ toMessage $ ChannelMsg user message
_ -> Reject _ -> Reject
where where
done = flip Done [] . FullMessage time line done = flip Done [] . Message time line
(splits, command, source, target, message) = parseMsgLine line (splits, command, source, target, message) = parseMsgLine line
quitMessage = strip . drop 1 . unwords . drop 2 $ splits quitMessage = strip . drop 1 . unwords . drop 2 $ splits
@ -71,7 +71,7 @@ lineParser = MessageParser "line" go
defaultParser :: MessageParser defaultParser :: MessageParser
defaultParser = MessageParser "default" go defaultParser = MessageParser "default" go
where where
go _ time line _ = flip Done [] . FullMessage time line $ go _ time line _ = flip Done [] . Message time line $
toMessage $ OtherMsg source command target message toMessage $ OtherMsg source command target message
where where
(_, command, source, target, message) = parseMsgLine line (_, command, source, target, message) = parseMsgLine line
@ -85,7 +85,7 @@ namesParser = MessageParser "names" go
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line]) (nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
in Done (FullMessage time allLines . toMessage $ NamesMsg nicks) otherMsgParts in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> Reject _ -> Reject
where where
(_ : command : target : _) = words line (_ : command : target : _) = words line
@ -94,23 +94,23 @@ namesParser = MessageParser "names" go
map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line' map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
formatCommand :: CommandFormatter formatCommand :: CommandFormatter
formatCommand botConfig@BotConfig { .. } command = formatCommand botConfig@BotConfig { .. } message =
msum . map (\formatter -> formatter botConfig command) $ defaultCommandFormatter : cmdFormatters msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
defaultCommandFormatter :: CommandFormatter defaultCommandFormatter :: CommandFormatter
defaultCommandFormatter BotConfig { .. } command defaultCommandFormatter BotConfig { .. } Message { .. }
| Just (PongCmd msg) <- fromCommand command = Just $ "PONG :" ++ msg | Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
| Just (PingCmd msg) <- fromCommand command = Just $ "PING :" ++ msg | Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
| Just NickCmd <- fromCommand command = Just $ "NICK " ++ botNick' | Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
| Just UserCmd <- fromCommand command = | Just UserCmd <- fromMessage message =
Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick' Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
| Just JoinCmd <- fromCommand command = Just $ "JOIN " ++ channel | Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
| Just QuitCmd <- fromCommand command = Just "QUIT" | Just QuitCmd <- fromMessage message = Just "QUIT"
| Just (ChannelMsgReply msg) <- fromCommand command = | Just (ChannelMsgReply msg) <- fromMessage message =
Just $ "PRIVMSG " ++ channel ++ " :" ++ msg Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
| Just (PrivMsgReply (User { .. }) msg) <- fromCommand command = | Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
| Just NamesCmd <- fromCommand command = Just $ "NAMES " ++ channel | Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
| otherwise = Nothing | otherwise = Nothing
where where
botNick' = nickToText botNick botNick' = nickToText botNick

16
hask-irc-core/Network/IRC/Types.hs
View File

@ -14,8 +14,8 @@ module Network.IRC.Types
Nick (..) Nick (..)
, User (..) , User (..)
, MessageC (..) , MessageC (..)
, Message , Message (..)
, FullMessage (..) , newMessage
, IdleMsg (..) , IdleMsg (..)
, NickInUseMsg (..) , NickInUseMsg (..)
, PingMsg (..) , PingMsg (..)
@ -32,8 +32,6 @@ module Network.IRC.Types
, ModeMsg (..) , ModeMsg (..)
, OtherMsg (..) , OtherMsg (..)
-- * IRC Commands -- * IRC Commands
, CommandC (..)
, Command
, PingCmd (..) , PingCmd (..)
, PongCmd (..) , PongCmd (..)
, ChannelMsgReply (..) , ChannelMsgReply (..)
@ -50,11 +48,6 @@ module Network.IRC.Types
, MessageParser (..) , MessageParser (..)
-- * Command Formatting -- * Command Formatting
, CommandFormatter , CommandFormatter
-- * Events
, EventC (..)
, Event
, EventResponse (..)
, QuitEvent(..)
-- * Bot -- * Bot
, BotConfig (..) , BotConfig (..)
, newBotConfig , newBotConfig
@ -68,8 +61,5 @@ module Network.IRC.Types
, MsgHandlerMaker (..) , MsgHandlerMaker (..)
) where ) where
import Network.IRC.Internal.Command.Types import Network.IRC.Message.Types
import Network.IRC.Internal.Event.Types
import Network.IRC.Internal.Message.Types
import Network.IRC.Internal.Types import Network.IRC.Internal.Types

57
hask-irc-core/Network/IRC/Util.hs
View File

@ -6,28 +6,17 @@ module Network.IRC.Util where
import qualified Data.Text.Format as TF import qualified Data.Text.Format as TF
import ClassyPrelude import ClassyPrelude
import Control.Arrow (Arrow) import Control.Arrow (Arrow)
import Control.Concurrent.Lifted (Chan) import Control.Monad.Base (MonadBase)
import Control.Monad.Base (MonadBase) import Data.Convertible (convert)
import Data.Convertible (convert) import Data.Text (strip)
import Data.Text (strip) import Data.Time (diffUTCTime)
import Data.Time (diffUTCTime)
oneSec :: Int oneSec :: Int
oneSec = 1000000 oneSec = 1000000
type Latch = MVar ()
latchIt :: Latch -> IO ()
latchIt latch = putMVar latch ()
awaitLatch :: Latch -> IO ()
awaitLatch latch = void $ takeMVar latch
type Channel a = (Chan a, Latch)
mapKeys :: IsMap map => map -> [ContainerKey map] mapKeys :: IsMap map => map -> [ContainerKey map]
mapKeys = map fst . mapToList mapKeys = map fst . mapToList
mapValues :: IsMap map => map -> [MapValue map] mapValues :: IsMap map => map -> [MapValue map]
mapValues = map snd . mapToList mapValues = map snd . mapToList
@ -64,21 +53,21 @@ relativeTime t1 t2 =
period = t1 `diffUTCTime` t2 period = t1 `diffUTCTime` t2
ranges = [(year*2, "{} years", year) ranges = [ (year*2, "{} years", year)
,(year, "a year", 0) , (year, "a year", 0)
,(month*2, "{} months", month) , (month*2, "{} months", month)
,(month, "a month", 0) , (month, "a month", 0)
,(week*2, "{} weeks", week) , (week*2, "{} weeks", week)
,(week, "a week", 0) , (week, "a week", 0)
,(day*2, "{} days", day) , (day*2, "{} days", day)
,(day, "a day", 0) , (day, "a day", 0)
,(hour*4, "{} hours", hour) , (hour*4, "{} hours", hour)
,(hour*3, "a few hours", 0) , (hour*3, "a few hours", 0)
,(hour*2, "{} hours", hour) , (hour*2, "{} hours", hour)
,(hour, "an hour", 0) , (hour, "an hour", 0)
,(minute*31, "{} minutes", minute) , (minute*31, "{} minutes", minute)
,(minute*30, "half an hour", 0) , (minute*30, "half an hour", 0)
,(minute*2, "{} minutes", minute) , (minute*2, "{} minutes", minute)
,(minute, "a minute", 0) , (minute, "a minute", 0)
,(0, "{} seconds", 1) , (0, "{} seconds", 1)
] ]

10
hask-irc-core/hask-irc-core.cabal
View File

@ -51,7 +51,7 @@ cabal-version: >=1.10
library library
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables, default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving, BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
DeriveDataTypeable DeriveDataTypeable, Trustworthy
build-depends: base >=4.5 && <4.8, build-depends: base >=4.5 && <4.8,
classy-prelude >=0.9 && <1.0, classy-prelude >=0.9 && <1.0,
@ -63,6 +63,7 @@ library
mtl >=2.1 && <2.3, mtl >=2.1 && <2.3,
network >=2.5 && <2.6, network >=2.5 && <2.6,
safecopy >=0.8 && <0.9, safecopy >=0.8 && <0.9,
stm >=2.4 && <2.5,
text >=1.1 && <1.2, text >=1.1 && <1.2,
text-format >=0.3 && <0.4, text-format >=0.3 && <0.4,
time >=1.4 && <1.5, time >=1.4 && <1.5,
@ -70,14 +71,13 @@ library
unix >=2.7 && <2.8 unix >=2.7 && <2.8
exposed-modules: Network.IRC, exposed-modules: Network.IRC,
Network.IRC.MessageBus,
Network.IRC.Types, Network.IRC.Types,
Network.IRC.Client, Network.IRC.Client,
Network.IRC.Util Network.IRC.Util
other-modules: Network.IRC.Internal.Command.Types, other-modules: Network.IRC.Internal.Types,
Network.IRC.Internal.Event.Types, Network.IRC.Message.Types,
Network.IRC.Internal.Message.Types,
Network.IRC.Internal.Types,
Network.IRC.Protocol, Network.IRC.Protocol,
Network.IRC.Bot, Network.IRC.Bot,
Network.IRC.Handlers.Core Network.IRC.Handlers.Core

1
hask-irc-handlers/Network/IRC/Handlers.hs
View File

@ -13,6 +13,7 @@ allMsgHandlerMakers :: [MsgHandlerMaker]
allMsgHandlerMakers = allMsgHandlerMakers =
[ authMsgHandlerMaker [ authMsgHandlerMaker
, greetMsgHandlerMaker , greetMsgHandlerMaker
, welcomeMsgHandlerMaker
, messageLoggerMsgHandlerMaker , messageLoggerMsgHandlerMaker
, nickTrackerMsgHandlerMaker , nickTrackerMsgHandlerMaker
, songSearchMsgHandlerMaker , songSearchMsgHandlerMaker

41
hask-irc-handlers/Network/IRC/Handlers/Auth.hs
View File

@ -13,8 +13,8 @@ import Data.Acid (AcidState, Query, Update, makeAcidic, query, update
openLocalState, createArchive) openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose) import Data.Acid.Local (createCheckpointAndClose)
import Network.IRC
import Network.IRC.Handlers.Auth.Types import Network.IRC.Handlers.Auth.Types
import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
-- database -- database
@ -42,12 +42,20 @@ issueToken acid user = do
-- handler -- handler
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage -> m [Command] authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m [Message]
authMessage state FullMessage { .. } authMessage state Message { .. }
| Just (PrivMsg user msg) <- fromMessage message | Just (PrivMsg user msg) <- fromMessage message
, "token" `isPrefixOf` msg = , "token" `isPrefixOf` msg = do
map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user) token <- io $ readIORef state >>= flip issueToken (userNick user)
authMessage _ _ = return [] map singleton . newMessage $ PrivMsgReply user token
| Just (AuthRequest user token reply) <- fromMessage message = io $ do
acid <- readIORef state
mt <- query acid (GetToken user)
case mt of
Just t -> putMVar reply (t == token)
Nothing -> putMVar reply False
return []
| otherwise = return []
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m () stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
stopAuth state = io $ do stopAuth state = io $ do
@ -55,26 +63,13 @@ stopAuth state = io $ do
createArchive acid createArchive acid
createCheckpointAndClose acid createCheckpointAndClose acid
authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> Event -> m EventResponse
authEvent state event = case fromEvent event of
Just (AuthEvent user token reply, _) -> io $ do
acid <- readIORef state
mt <- query acid (GetToken user)
case mt of
Just t -> putMVar reply (t == token)
Nothing -> putMVar reply False
return RespNothing
_ -> return RespNothing
authMsgHandlerMaker :: MsgHandlerMaker authMsgHandlerMaker :: MsgHandlerMaker
authMsgHandlerMaker = MsgHandlerMaker "auth" go authMsgHandlerMaker = MsgHandlerMaker "auth" go
where where
helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token" helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
go BotConfig { .. } _ "auth" = do go BotConfig { .. } _ = do
state <- io $ openLocalState emptyAuth >>= newIORef state <- io $ openLocalState emptyAuth >>= newIORef
return . Just $ newMsgHandler { onMessage = authMessage state return $ newMsgHandler { onMessage = authMessage state
, onEvent = authEvent state , onStop = stopAuth state
, onStop = stopAuth state , handlerHelp = return $ singletonMap "token" (helpMsg botNick) }
, onHelp = return $ singletonMap "token" (helpMsg botNick) }
go _ _ _ = return Nothing

13
hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs
View File

@ -17,10 +17,13 @@ emptyAuth = Auth mempty
$(deriveSafeCopy 0 'base ''Auth) $(deriveSafeCopy 0 'base ''Auth)
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable) data AuthRequest = AuthRequest Nick Token (MVar Bool) deriving (Eq, Typeable)
instance EventC AuthEvent instance MessageC AuthRequest
instance Show AuthEvent where instance Show AuthRequest where
show (AuthEvent nick token _) = show (AuthRequest nick token _) =
"AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]" "AuthRequest[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"
instance Ord AuthRequest where
(AuthRequest nick1 _ _) `compare` (AuthRequest nick2 _ _) = nick1 `compare` nick2

33
hask-irc-handlers/Network/IRC/Handlers/Greet.hs
View File

@ -1,34 +1,37 @@
module Network.IRC.Handlers.Greet (greetMsgHandlerMaker) where module Network.IRC.Handlers.Greet (greetMsgHandlerMaker, welcomeMsgHandlerMaker) where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Network.IRC.Types import Network.IRC
import Network.IRC.Util import Network.IRC.Util
greetMsgHandlerMaker :: MsgHandlerMaker greetMsgHandlerMaker :: MsgHandlerMaker
greetMsgHandlerMaker = MsgHandlerMaker "greeter" go greetMsgHandlerMaker =
where MsgHandlerMaker "greeter" $ \_ _ -> return $ newMsgHandler { onMessage = greeter }
go _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
go _ _ _ = return Nothing
greeter :: MonadMsgHandler m => FullMessage -> m [Command] welcomeMsgHandlerMaker :: MsgHandlerMaker
greeter FullMessage { .. } = case fromMessage message of welcomeMsgHandlerMaker =
MsgHandlerMaker "welcomer" $ \_ _ -> return $ newMsgHandler { onMessage = welcomer }
greeter :: MonadMsgHandler m => Message -> m [Message]
greeter Message { .. } = case fromMessage message of
Just (ChannelMsg user msg) -> Just (ChannelMsg user msg) ->
return . maybeToList . map (toCommand . ChannelMsgReply . (++ nickToText (userNick user)) . (++ " ")) let reply = maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
. find (== clean msg) $ greetings . find (== clean msg) $ greetings
in mapM newMessage reply
_ -> return [] _ -> return []
where where
greetings = [ "hi", "hello", "hey", "sup", "bye" greetings = [ "hi", "hello", "hey", "sup", "bye"
, "good morning", "good evening", "good night" ] , "good morning", "good evening", "good night" ]
welcomer :: MonadMsgHandler m => FullMessage -> m [Command] welcomer :: MonadMsgHandler m => Message -> m [Message]
welcomer FullMessage { .. } = case fromMessage message of welcomer Message { .. } = case fromMessage message of
Just (JoinMsg user) -> do Just (JoinMsg user) -> do
BotConfig { .. } <- ask BotConfig { .. } <- ask
return [toCommand . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user) if userNick user /= botNick
| userNick user /= botNick] then map singleton . newMessage . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
else return []
_ -> return [] _ -> return []

20
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
View File

@ -14,7 +14,7 @@ import System.Directory (createDirectoryIfMissing, getModificationTime,
import System.FilePath (FilePath, (</>), (<.>)) import System.FilePath (FilePath, (</>), (<.>))
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
import Network.IRC.Types import Network.IRC
import Network.IRC.Util import Network.IRC.Util
type LoggerState = Maybe (Handle, Day) type LoggerState = Maybe (Handle, Day)
@ -22,18 +22,17 @@ type LoggerState = Maybe (Handle, Day)
messageLoggerMsgHandlerMaker :: MsgHandlerMaker messageLoggerMsgHandlerMaker :: MsgHandlerMaker
messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
where where
go botConfig _ "messagelogger" = do go botConfig _ = do
state <- io $ newIORef Nothing state <- io $ newIORef Nothing
initMessageLogger botConfig state initMessageLogger botConfig state
return . Just $ newMsgHandler { onMessage = flip messageLogger state return $ newMsgHandler { onMessage = flip messageLogger state
, onStop = exitMessageLogger state } , onStop = exitMessageLogger state }
go _ _ _ = return Nothing
getLogFilePath :: BotConfig -> IO FilePath getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do getLogFilePath BotConfig { .. } = do
logFileDir <- CF.require config "messagelogger.logdir" logFileDir <- CF.require config "messagelogger.logdir"
createDirectoryIfMissing True logFileDir createDirectoryIfMissing True logFileDir
return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log" return $ logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
openLogFile :: FilePath -> IO Handle openLogFile :: FilePath -> IO Handle
openLogFile logFilePath = do openLogFile logFilePath = do
@ -51,7 +50,7 @@ initMessageLogger botConfig state = do
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m () exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst) exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command] withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message]
withLogFile action state = do withLogFile action state = do
botConfig <- ask botConfig <- ask
io $ do io $ do
@ -73,8 +72,8 @@ withLogFile action state = do
return [] return []
messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command] messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message]
messageLogger FullMessage { .. } messageLogger Message { .. }
| Just (ChannelMsg user msg) <- fromMessage message = | Just (ChannelMsg user msg) <- fromMessage message =
log "<{}> {}" [nick user, msg] log "<{}> {}" [nick user, msg]
| Just (ActionMsg user msg) <- fromMessage message = | Just (ActionMsg user msg) <- fromMessage message =
@ -91,7 +90,8 @@ messageLogger FullMessage { .. }
log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick] log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
| Just (NamesMsg nicks) <- fromMessage message = | Just (NamesMsg nicks) <- fromMessage message =
log "** USERS {}" [unwords . map nickToText $ nicks] log "** USERS {}" [unwords . map nickToText $ nicks]
| otherwise = const $ return [] | otherwise =
const $ return []
where where
nick = nickToText . userNick nick = nickToText . userNick

59
hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
View File

@ -18,8 +18,8 @@ import Data.Convertible (convert)
import Data.IxSet (getOne, (@=)) import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime) import Data.Time (addUTCTime, NominalDiffTime)
import Network.IRC
import Network.IRC.Handlers.NickTracker.Internal.Types import Network.IRC.Handlers.NickTracker.Internal.Types
import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
-- database -- database
@ -54,8 +54,8 @@ data NickTrackingState = NickTrackingState { acid :: AcidState NickTr
, onlineNicks :: HashSet Nick , onlineNicks :: HashSet Nick
, lastRefreshOn :: UTCTime } , lastRefreshOn :: UTCTime }
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> FullMessage -> m [Command] nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Message]
nickTrackerMsg state FullMessage { .. } nickTrackerMsg state Message { .. }
| Just (ChannelMsg (User { .. }) msg) <- fromMessage message = | Just (ChannelMsg (User { .. }) msg) <- fromMessage message =
updateNickTrack state userNick msg msgTime >> handleCommands userNick msg updateNickTrack state userNick msg msgTime >> handleCommands userNick msg
| Just (ActionMsg (User { .. }) msg) <- fromMessage message = | Just (ActionMsg (User { .. }) msg) <- fromMessage message =
@ -68,15 +68,18 @@ nickTrackerMsg state FullMessage { .. }
updateNickTrack state userNick msg msgTime >> remove userNick >> return [] updateNickTrack state userNick msg msgTime >> remove userNick >> return []
| Just (NickMsg (User { .. }) newNick) <- fromMessage message = | Just (NickMsg (User { .. }) newNick) <- fromMessage message =
handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return [] handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return []
| Just (NamesMsg nicks) <- fromMessage message = do | Just (NamesMsg nicks) <- fromMessage message = do
forM_ nicks $ \n -> updateNickTrack state n "" msgTime forM_ nicks $ \n -> updateNickTrack state n "" msgTime
refresh nicks >> updateRefreshTime >> return [] refresh nicks >> updateRefreshTime >> return []
| Just IdleMsg <- fromMessage message = do | Just IdleMsg <- fromMessage message = do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
if addUTCTime refreshInterval lastRefreshOn < msgTime if addUTCTime refreshInterval lastRefreshOn < msgTime
then updateRefreshTime >> return [toCommand NamesCmd] then updateRefreshTime >> map singleton (newMessage NamesCmd)
else return [] else return []
| otherwise = return [] | Just (NickTrackRequest nick reply) <- fromMessage message = io $ do
NickTrackingState { .. } <- readIORef state
getByNick acid nick >>= putMVar reply >> return []
| otherwise = return []
where where
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime } updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
@ -96,8 +99,8 @@ nickTrackerMsg state FullMessage { .. }
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m () updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m ()
updateNickTrack state nck message msgTime = io $ do updateNickTrack state nck message msgTime = io $ do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
mnt <- getByNick acid nck mnt <- getByNick acid nck
(message', lastMessageOn', cn) <- case (message, mnt) of (message', lastMessageOn', cn) <- case (message, mnt) of
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick) ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick) (_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
@ -108,9 +111,9 @@ updateNickTrack state nck message msgTime = io $ do
handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m () handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m ()
handleNickChange state prevNick newNick msgTime = io $ do handleNickChange state prevNick newNick msgTime = io $ do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
mpnt <- getByNick acid prevNick mpnt <- getByNick acid prevNick
mnt <- getByNick acid newNick mnt <- getByNick acid newNick
mInfo <- case (mpnt, mnt) of mInfo <- case (mpnt, mnt) of
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime) (Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Just pnt, Nothing) -> (Just pnt, Nothing) ->
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt) return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
@ -128,26 +131,27 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
withNickTracks :: MonadMsgHandler m withNickTracks :: MonadMsgHandler m
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) => (Text -> [NickTrack] -> HashSet Nick -> IO Text)
-> IORef NickTrackingState -> Nick -> Text -> IORef NickTrackingState -> Nick -> Text
-> m [Command] -> m [Message]
withNickTracks f state _ msg = io $ do withNickTracks f state _ msg = io $ do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
let nick = clean . unwords . drop 1 . words $ msg let nick = clean . unwords . drop 1 . words $ msg
if nick == "" if nick == ""
then return [] then return []
else do else do
mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
map (singleton . toCommand . ChannelMsgReply) $ case mcn of reply <- case mcn of
Nothing -> return $ "Unknown nick: " ++ nick Nothing -> return $ "Unknown nick: " ++ nick
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
map singleton . newMessage . ChannelMsgReply $ reply
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
let nicks = map ((\(Nick n) -> n) . nick) nickTracks let nicks = map ((\(Nick n) -> n) . nick) nickTracks
return . (nck ++) $ if length nicks == 1 return . (nck ++) $ if length nicks == 1
then " has only one nick" then " has only one nick"
else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks) else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
let NickTrack { lastSeenOn = lastSeenOn' let NickTrack { lastSeenOn = lastSeenOn'
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks , nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
@ -165,21 +169,14 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++ (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
" said: " ++ lastMessage') " said: " ++ lastMessage')
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command] handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
handleForgetNicksCommand state nick _ = do handleForgetNicksCommand state nick _ = do
NickTrackingState { .. } <- readIORef state NickTrackingState { .. } <- readIORef state
io $ do io $ do
Just nt <- getByNick acid nick Just nt <- getByNick acid nick
cn <- newCanonicalNick cn <- newCanonicalNick
saveNickTrack acid $ nt { canonicalNick = cn } saveNickTrack acid $ nt { canonicalNick = cn }
return [toCommand . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick] map singleton . newMessage . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> Event -> m EventResponse
nickTrackerEvent state event = case fromEvent event of
Just (NickTrackRequest nick reply, _) -> io $ do
NickTrackingState { .. } <- readIORef state
getByNick acid nick >>= putMVar reply >> return RespNothing
_ -> return RespNothing
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m () stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
stopNickTracker state = io $ do stopNickTracker state = io $ do
@ -195,14 +192,12 @@ nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"), ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ] ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
go BotConfig { .. } _ "nicktracker" = do go BotConfig { .. } _ = do
state <- io $ do state <- io $ do
now <- getCurrentTime now <- getCurrentTime
refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int) refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int)
acid <- openLocalState emptyNickTracking acid <- openLocalState emptyNickTracking
newIORef (NickTrackingState acid refreshInterval mempty now) newIORef (NickTrackingState acid refreshInterval mempty now)
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state return $ newMsgHandler { onMessage = nickTrackerMsg state
, onEvent = nickTrackerEvent state , onStop = stopNickTracker state
, onStop = stopNickTracker state , handlerHelp = return helpMsgs }
, onHelp = return helpMsgs }
go _ _ _ = return Nothing

36
hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs
View File

@ -3,24 +3,23 @@
module Network.IRC.Handlers.NickTracker.Internal.Types where module Network.IRC.Handlers.NickTracker.Internal.Types where
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (Chan, writeChan) import Data.Data (Data)
import Data.Data (Data) import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) import Data.SafeCopy (base, deriveSafeCopy)
import Data.SafeCopy (base, deriveSafeCopy)
import Network.IRC.Types import Network.IRC
newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text } newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text }
deriving (Eq, Ord, Show, Data, Typeable) deriving (Eq, Ord, Show, Data, Typeable)
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable) newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
data NickTrack = NickTrack { data NickTrack = NickTrack
nick :: !Nick, { nick :: !Nick
canonicalNick :: !CanonicalNick, , canonicalNick :: !CanonicalNick
lastSeenOn :: !UTCTime, , lastSeenOn :: !UTCTime
lastMessageOn :: !UTCTime, , lastMessageOn :: !UTCTime
lastMessage :: !Text , lastMessage :: !Text
} deriving (Eq, Ord, Show, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
instance Indexable NickTrack where instance Indexable NickTrack where
empty = ixSet [ ixFun $ (: []) . nick empty = ixSet [ ixFun $ (: []) . nick
@ -40,14 +39,17 @@ emptyNickTracking = NickTracking empty
data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable) data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
instance EventC NickTrackRequest instance MessageC NickTrackRequest
instance Show NickTrackRequest where instance Show NickTrackRequest where
show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]" show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
getCanonicalNick :: Chan Event -> Nick -> IO (Maybe CanonicalNick) instance Ord NickTrackRequest where
getCanonicalNick eventChan nick = do (NickTrackRequest nick1 _) `compare` (NickTrackRequest nick2 _) = nick1 `compare` nick2
getCanonicalNick :: MessageChannel Message -> Nick -> IO (Maybe CanonicalNick)
getCanonicalNick messageChannel nick = do
reply <- newEmptyMVar reply <- newEmptyMVar
request <- toEvent $ NickTrackRequest nick reply request <- newMessage $ NickTrackRequest nick reply
writeChan eventChan request sendMessage messageChannel request
map (map canonicalNick) $ takeMVar reply map (map canonicalNick) $ takeMVar reply

18
hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs
View File

@ -16,7 +16,7 @@ import Network.Curl.Aeson (curlAesonGet, CurlAesonException)
import Network.HTTP.Base (urlEncode) import Network.HTTP.Base (urlEncode)
import System.Log.Logger.TH (deriveLoggers) import System.Log.Logger.TH (deriveLoggers)
import Network.IRC.Types import Network.IRC
$(deriveLoggers "HSL" [HSL.ERROR]) $(deriveLoggers "HSL" [HSL.ERROR])
@ -25,10 +25,9 @@ songSearchMsgHandlerMaker = MsgHandlerMaker "songsearch" go
where where
helpMsg = "Search for song. !m <song> or !m <artist> - <song>" helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
go _ _ "songsearch" = go _ _ =
return . Just $ newMsgHandler { onMessage = songSearch, return $ newMsgHandler { onMessage = songSearch
onHelp = return $ singletonMap "!m" helpMsg } , handlerHelp = return $ singletonMap "!m" helpMsg }
go _ _ _ = return Nothing
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
deriving (Show, Eq) deriving (Show, Eq)
@ -38,15 +37,15 @@ instance FromJSON Song where
parseJSON a | a == emptyArray = return NoSong parseJSON a | a == emptyArray = return NoSong
parseJSON _ = mempty parseJSON _ = mempty
songSearch :: MonadMsgHandler m => FullMessage -> m [Command] songSearch :: MonadMsgHandler m => Message -> m [Message]
songSearch FullMessage { .. } songSearch Message { .. }
| Just (ChannelMsg _ msg) <- fromMessage message | Just (ChannelMsg _ msg) <- fromMessage message
, "!m " `isPrefixOf` msg = do , "!m " `isPrefixOf` msg = do
BotConfig { .. } <- ask BotConfig { .. } <- ask
liftIO $ do liftIO $ do
let query = strip . drop 3 $ msg let query = strip . drop 3 $ msg
mApiKey <- CF.lookup config "songsearch.tinysong_apikey" mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
map (singleton . toCommand . ChannelMsgReply) $ case mApiKey of reply <- map ChannelMsgReply $ case mApiKey of
Nothing -> do Nothing -> do
errorM "tinysong api key not found in config" errorM "tinysong api key not found in config"
return $ "Error while searching for " ++ query return $ "Error while searching for " ++ query
@ -62,4 +61,5 @@ songSearch FullMessage { .. }
Right song -> return $ case song of Right song -> return $ case song of
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
NoSong -> "No song found for: " ++ query NoSong -> "No song found for: " ++ query
map singleton . newMessage $ reply
| otherwise = return [] | otherwise = return []

66
hask-irc-handlers/Network/IRC/Handlers/Tell.hs
View File

@ -6,19 +6,18 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
import qualified Data.IxSet as IS import qualified Data.IxSet as IS
import ClassyPrelude hiding (swap) import ClassyPrelude hiding (swap)
import Control.Concurrent.Lifted (Chan) import Control.Monad.Reader (ask)
import Control.Monad.Reader (ask) import Control.Monad.State (get, put)
import Control.Monad.State (get, put) import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, openLocalState, createArchive)
openLocalState, createArchive) import Data.Acid.Local (createCheckpointAndClose)
import Data.Acid.Local (createCheckpointAndClose) import Data.IxSet ((@=))
import Data.IxSet ((@=)) import Data.Text (split, strip)
import Data.Text (split, strip)
import Network.IRC
import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Handlers.Tell.Internal.Types import Network.IRC.Handlers.Tell.Internal.Types
import Network.IRC.Types
import Network.IRC.Util import Network.IRC.Util
-- database -- database
@ -47,8 +46,8 @@ saveTell acid = update acid . SaveTellQ
newtype TellState = TellState { acid :: AcidState Tells } newtype TellState = TellState { acid :: AcidState Tells }
tellMsg :: MonadMsgHandler m => Chan Event -> IORef TellState -> FullMessage -> m [Command] tellMsg :: MonadMsgHandler m => MessageChannel Message -> IORef TellState -> Message -> m [Message]
tellMsg eventChan state FullMessage { .. } tellMsg messageChannel state Message { .. }
| Just (ChannelMsg (User { .. }) msg) <- fromMessage message | Just (ChannelMsg (User { .. }) msg) <- fromMessage message
, command msg == "!tell" , command msg == "!tell"
, args <- drop 1 . words $ msg , args <- drop 1 . words $ msg
@ -61,7 +60,7 @@ tellMsg eventChan state FullMessage { .. }
if null tell if null tell
then return [] then return []
else do else do
res <- forM nicks $ \nick -> handleTell acid nick tell res <- forM nicks $ \nick -> handleTell acid userNick nick tell
let (fails, passes) = partitionEithers res let (fails, passes) = partitionEithers res
let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++ let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
(if null passes then [] else (if null passes then [] else
@ -73,22 +72,26 @@ tellMsg eventChan state FullMessage { .. }
if null tell if null tell
then return [] then return []
else do else do
res <- handleTell acid nick tell res <- handleTell acid userNick nick tell
let rep = case res of let rep = case res of
Left _ -> "Unknown nick: " ++ nickToText nick Left _ -> "Unknown nick: " ++ nickToText nick
Right _ -> "Message noted and will be passed on to " ++ nickToText nick Right _ -> "Message noted and will be passed on to " ++ nickToText nick
return [rep] return [rep]
tells <- getTellsToDeliver userNick tells <- getTellsToDeliver userNick
return . map (textToReply userNick) $ (reps ++ tells) mapM (textToReply userNick) (reps ++ tells)
| Just (ChannelMsg (User { .. }) _) <- fromMessage message = | Just (ChannelMsg (User { .. }) _) <- fromMessage message = io $ do
io $ map (map (textToReply userNick)) $ getTellsToDeliver userNick tells <- getTellsToDeliver userNick
mapM (textToReply userNick) tells
| Just (TellRequest user msg) <- fromMessage message = do
tellMsg messageChannel state . Message msgTime "" . toMessage $ ChannelMsg user msg
return []
| otherwise = return [] | otherwise = return []
where where
command msg = clean . fromMaybe "" . headMay . words $ msg command msg = clean . fromMaybe "" . headMay . words $ msg
parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',') parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
textToReply nick t = toCommand . ChannelMsgReply $ nickToText nick ++ ": " ++ t textToReply nick t = newMessage . ChannelMsgReply $ nickToText nick ++ ": " ++ t
tellToMsg Tell { .. } = tellToMsg Tell { .. } =
relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
@ -97,7 +100,7 @@ tellMsg eventChan state FullMessage { .. }
getTellsToDeliver nick = io $ do getTellsToDeliver nick = io $ do
TellState { .. } <- readIORef state TellState { .. } <- readIORef state
mcn <- getCanonicalNick eventChan nick mcn <- getCanonicalNick messageChannel nick
case mcn of case mcn of
Nothing -> return [] Nothing -> return []
Just canonicalNick -> do Just canonicalNick -> do
@ -106,19 +109,12 @@ tellMsg eventChan state FullMessage { .. }
saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime } saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
return . tellToMsg $ tell return . tellToMsg $ tell
handleTell acid nick tell = do handleTell acid userNick nick tell = do
mcn <- getCanonicalNick eventChan nick mcn <- getCanonicalNick messageChannel nick
case mcn of case mcn of
Nothing -> return . Left . nickToText $ nick Nothing -> return . Left . nickToText $ nick
Just canonicalNick -> Just canonicalNick ->
saveTell acid (newTell nick canonicalNick tell) >> (return . Right . nickToText $ nick) saveTell acid (newTell userNick canonicalNick tell) >> (return . Right . nickToText $ nick)
tellEvent :: MonadMsgHandler m => Chan Event -> IORef TellState -> Event -> m EventResponse
tellEvent eventChan state event = case fromEvent event of
Just (TellRequest user message, evTime) -> do
tellMsg eventChan state . FullMessage evTime "" . toMessage $ ChannelMsg user message
return RespNothing
_ -> return RespNothing
stopTell :: MonadMsgHandler m => IORef TellState -> m () stopTell :: MonadMsgHandler m => IORef TellState -> m ()
stopTell state = io $ do stopTell state = io $ do
@ -129,15 +125,13 @@ stopTell state = io $ do
tellMsgHandlerMaker :: MsgHandlerMaker tellMsgHandlerMaker :: MsgHandlerMaker
tellMsgHandlerMaker = MsgHandlerMaker "tell" go tellMsgHandlerMaker = MsgHandlerMaker "tell" go
where where
go BotConfig { .. } eventChan "tell" = do go BotConfig { .. } messageChannel = do
acid <- openLocalState emptyTells acid <- openLocalState emptyTells
state <- newIORef (TellState acid) state <- newIORef (TellState acid)
return . Just $ newMsgHandler { onMessage = tellMsg eventChan state return $ newMsgHandler { onMessage = tellMsg messageChannel state
, onEvent = tellEvent eventChan state , onStop = stopTell state
, onStop = stopTell state , handlerHelp = return helpMsgs }
, onHelp = return helpMsgs }
go _ _ _ = return Nothing
helpMsgs = singletonMap "!tell" $ helpMsgs = singletonMap "!tell" $
"Publically passes a message to a user or a bunch of users. " ++ "Publically pass a message to a user or a bunch of users. " ++
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>." "!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>."

38
hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs
View File

@ -4,27 +4,26 @@
module Network.IRC.Handlers.Tell.Internal.Types where module Network.IRC.Handlers.Tell.Internal.Types where
import ClassyPrelude import ClassyPrelude
import Control.Concurrent.Lifted (Chan, writeChan) import Data.Data (Data)
import Data.Data (Data) import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) import Data.SafeCopy (base, deriveSafeCopy)
import Data.SafeCopy (base, deriveSafeCopy)
import Network.IRC
import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Types
newtype TellId = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num) newtype TellId = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable) data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
data Tell = Tell { data Tell = Tell
tellId :: !TellId, { tellId :: !TellId
tellFromNick :: !Nick, , tellFromNick :: !Nick
tellToNick :: !CanonicalNick, , tellToNick :: !CanonicalNick
tellTopic :: !(Maybe Text), , tellTopic :: !(Maybe Text)
tellStatus :: !TellStatus, , tellStatus :: !TellStatus
tellCreatedOn :: !UTCTime, , tellCreatedOn :: !UTCTime
tellDeliveredOn :: !(Maybe UTCTime), , tellDeliveredOn :: !(Maybe UTCTime)
tellContent :: !Text , tellContent :: !Text
} deriving (Eq, Ord, Show, Data, Typeable) } deriving (Eq, Ord, Show, Data, Typeable)
instance Indexable Tell where instance Indexable Tell where
empty = ixSet [ ixFun $ (: []) . tellId empty = ixSet [ ixFun $ (: []) . tellId
@ -42,13 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells)
emptyTells :: Tells emptyTells :: Tells
emptyTells = Tells (TellId 1) empty emptyTells = Tells (TellId 1) empty
data TellRequest = TellRequest User Text deriving (Eq, Typeable) data TellRequest = TellRequest User Text deriving (Eq, Typeable, Ord)
instance EventC TellRequest instance MessageC TellRequest
instance Show TellRequest where instance Show TellRequest where
show (TellRequest user tell) = show (TellRequest user tell) =
"TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]" "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
sendTell :: Chan Event -> User -> Text -> IO () sendTell :: MessageChannel Message -> User -> Text -> IO ()
sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan sendTell messageChannel user tell =
newMessage (TellRequest user tell) >>= sendMessage messageChannel

2
hask-irc-runner/Main.hs
View File

@ -4,7 +4,7 @@ import ClassyPrelude hiding (getArgs)
import System.Environment (getArgs, getProgName) import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import Network.IRC.Client import Network.IRC
import Network.IRC.Config import Network.IRC.Config
main :: IO () main :: IO ()

12
hask-irc-runner/Network/IRC/Config.hs
View File

@ -7,8 +7,8 @@ import qualified Data.Configurator as CF
import ClassyPrelude import ClassyPrelude
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
import Network.IRC
import Network.IRC.Handlers import Network.IRC.Handlers
import Network.IRC.Types
instance Configured a => Configured [a] where instance Configured a => Configured [a] where
convert (List xs) = Just . mapMaybe convert $ xs convert (List xs) = Just . mapMaybe convert $ xs
@ -19,10 +19,14 @@ loadBotConfig configFile = do
eConfig <- try $ CF.load [CF.Required configFile] eConfig <- try $ CF.load [CF.Required configFile]
case eConfig of case eConfig of
Left (ParseError _ _) -> error "Error while loading config" Left (ParseError _ _) -> error "Error while loading config"
Right config -> do Right config -> do
eBotConfig <- try $ do eBotConfig <- try $ do
handlers :: [Text] <- CF.require config "msghandlers" handlers :: [Text] <- CF.require config "msghandlers"
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
let handlerMakers = foldl' (\m maker -> insertMap (msgHandlerName maker) maker m) mempty
. filter (\MsgHandlerMaker { .. } -> msgHandlerName `member` handlerInfo)
$ allMsgHandlerMakers
botConfig <- newBotConfig <$> botConfig <- newBotConfig <$>
CF.require config "server" <*> CF.require config "server" <*>
CF.require config "port" <*> CF.require config "port" <*>
@ -30,7 +34,7 @@ loadBotConfig configFile = do
(Nick <$> CF.require config "nick") <*> (Nick <$> CF.require config "nick") <*>
CF.require config "timeout" CF.require config "timeout"
return botConfig { msgHandlerInfo = handlerInfo return botConfig { msgHandlerInfo = handlerInfo
, msgHandlerMakers = allMsgHandlerMakers , msgHandlerMakers = handlerMakers
, config = config , config = config
} }