Major refactoring

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
master
Abhinav Sarkar 8 years ago
parent e61cab74ed
commit 757285f4fd
  1. 21
      hask-irc-core/Network/IRC.hs
  2. 136
      hask-irc-core/Network/IRC/Bot.hs
  3. 135
      hask-irc-core/Network/IRC/Client.hs
  4. 58
      hask-irc-core/Network/IRC/Handlers/Core.hs
  5. 67
      hask-irc-core/Network/IRC/Internal/Command/Types.hs
  6. 57
      hask-irc-core/Network/IRC/Internal/Event/Types.hs
  7. 117
      hask-irc-core/Network/IRC/Internal/Types.hs
  8. 75
      hask-irc-core/Network/IRC/Message/Types.hs
  9. 58
      hask-irc-core/Network/IRC/MessageBus.hs
  10. 44
      hask-irc-core/Network/IRC/Protocol.hs
  11. 16
      hask-irc-core/Network/IRC/Types.hs
  12. 57
      hask-irc-core/Network/IRC/Util.hs
  13. 10
      hask-irc-core/hask-irc-core.cabal
  14. 1
      hask-irc-handlers/Network/IRC/Handlers.hs
  15. 41
      hask-irc-handlers/Network/IRC/Handlers/Auth.hs
  16. 13
      hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs
  17. 33
      hask-irc-handlers/Network/IRC/Handlers/Greet.hs
  18. 20
      hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
  19. 59
      hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
  20. 36
      hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs
  21. 18
      hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs
  22. 68
      hask-irc-handlers/Network/IRC/Handlers/Tell.hs
  23. 38
      hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs
  24. 2
      hask-irc-runner/Main.hs
  25. 12
      hask-irc-runner/Network/IRC/Config.hs

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

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

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

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

@ -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

@ -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

@ -8,15 +8,13 @@ module Network.IRC.Internal.Types where
import qualified Data.Configurator as CF
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Network.IRC.Internal.Command.Types
import Network.IRC.Internal.Event.Types
import Network.IRC.Internal.Message.Types
import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Network.IRC.Message.Types
import Network.IRC.MessageBus
import Network.IRC.Util
-- ** Message Parsing
@ -25,17 +23,17 @@ import Network.IRC.Util
type MessageParserId = Text
-- | A part of a mutlipart message.
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
, msgPartTarget :: !Text
, msgPartTime :: !UTCTime
, msgPartLine :: !Text
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
, msgPartTarget :: !Text
, msgPartTime :: !UTCTime
, msgPartLine :: !Text
} deriving (Eq, Show)
-- | The result of parsing a message line.
data MessageParseResult =
Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts.
| Partial ![MessagePart] -- ^ A partial message with message parts received yet.
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
Done !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts.
| Partial ![MessagePart] -- ^ A partial message with message parts received yet.
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
deriving (Eq, Show)
-- | A message parser used for parsing text lines from the server to 'Message's.
@ -47,7 +45,7 @@ data MessageParser = MessageParser
-- ** Command Formatting
-- | 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
@ -58,11 +56,11 @@ type MsgHandlerName = Text
data BotConfig = BotConfig
{
-- | The server to connect to.
server :: !Text
botServer :: !Text
-- | The port to connect to.
, port :: !Int
, botPort :: !Int
-- | The channel to join.
, channel :: !Text
, botChannel :: !Text
-- | Nick of the bot.
, botNick :: !Nick
-- | 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.
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
-- | 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.
, msgParsers :: ![MessageParser]
-- | 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
show BotConfig { .. } = "BotConfig[ server = " ++ show server ++ "\n" ++
"port = " ++ show port ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]"
show BotConfig { .. } = "BotConfig {" ++ "\n" ++
"server = " ++ show botServer ++ "\n" ++
"port = " ++ show botPort ++ "\n" ++
"channel = " ++ show botChannel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }"
-- | Creates a new bot config with essential fields leaving rest fields empty.
newBotConfig :: Text -- ^ server
-> Int -- ^ port
-> Text -- ^ channel
-> Nick -- ^ botNick
-> Int -- ^ botTimeout
newBotConfig :: Text -- ^ server
-> Int -- ^ port
-> Text -- ^ channel
-> Nick -- ^ botNick
-> Int -- ^ botTimeout
-> BotConfig
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.
data Bot = Bot
@ -111,15 +110,15 @@ data Bot = Bot
}
-- | The current status of the bot.
data BotStatus = Connected -- ^ Connected to the server
| Disconnected -- ^ Disconnected from the server.
| Joined -- ^ Joined the channel.
| Kicked -- ^ Kicked from the channel.
| Errored -- ^ Some unhandled error happened.
| Idle -- ^ No communication with the server. The bot is idle.
-- If the bot stays idle for 'botTimeout' seconds, it disconnects.
| Interrupted -- ^ Interrupted using external signals like SIGINT.
| NickNotAvailable -- ^ Bot's nick already taken on the server.
data BotStatus = Connected -- ^ Connected to the server
| Disconnected -- ^ Disconnected from the server.
| Joined -- ^ Joined the channel.
| Kicked -- ^ Kicked from the channel.
| Errored -- ^ Some unhandled error happened.
| Idle -- ^ No communication with the server. The bot is idle.
-- If the bot stays idle for 'botTimeout' seconds, it disconnects.
| Interrupted -- ^ Interrupted using external signals like SIGINT.
| NickNotAvailable -- ^ Bot's nick already taken on the server.
deriving (Show, Eq, Ord)
-- | 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
-- to the message which the bot sends to the server.
onMessage :: !(forall m . MonadMsgHandler m => FullMessage -> m [Command])
-- | 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)
onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message])
-- | 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.
, 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.
newMsgHandler :: MsgHandler
newMsgHandler = MsgHandler
{ onMessage = const $ return []
, onStop = return ()
, onEvent = const $ return RespNothing
, onHelp = return mempty
{ onMessage = const $ return mempty
, onStop = return ()
, handlerHelp = return mempty
}
-- | A message handler maker which creates a new message handler.
@ -187,7 +184,7 @@ data MsgHandlerMaker = MsgHandlerMaker
-- | The name of the message handler.
msgHandlerName :: !MsgHandlerName
-- | 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
@ -198,19 +195,11 @@ instance Ord MsgHandlerMaker where
-- | Handles a message using a given message handler.
handleMessage :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config.
-> FullMessage -- ^ The message to handle.
-> IO [Command] -- ^ A list of commands to be sent to the server.
-> Message -- ^ The message to handle.
-> IO [Message] -- ^ A list of commands to be sent to the server.
handleMessage MsgHandler { .. } botConfig =
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.
stopMsgHandler :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config.
@ -223,4 +212,4 @@ getHelp :: MsgHandler -- ^ The message handler.
-> BotConfig -- ^ The bot config.
-> IO (Map Text Text) -- ^ A map of the commands supported by this message handler to their help messages.
getHelp MsgHandler { .. } botConfig =
flip runReaderT botConfig . _runMsgHandler $ onHelp
flip runReaderT botConfig . _runMsgHandler $ handlerHelp

@ -4,15 +4,14 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}
module Network.IRC.Internal.Message.Types where
module Network.IRC.Message.Types where
import ClassyPrelude
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast)
-- ** IRC Message
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast)
-- | An IRC nick.
newtype Nick = Nick { nickToText :: Text }
@ -34,31 +33,36 @@ data User
} deriving (Show, Eq, Ord)
-- | 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.
, 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)
-- | The typeclass for different types of IRC messages.
class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
toMessage :: msg -> Message
toMessage = Message
toMessage :: msg -> MessageW
toMessage = MessageW
fromMessage :: Message -> Maybe msg
fromMessage (Message msg) = cast msg
fromMessage :: MessageW -> Maybe msg
fromMessage (MessageW msg) = cast msg
-- | 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
show (Message m) = show m
instance Show MessageW where
show (MessageW m) = show m
instance Eq Message where
Message m1 == Message m2 = case cast m1 of
instance Eq MessageW where
MessageW m1 == MessageW m2 = case cast m1 of
Just m1' -> m1' == m2
_ -> 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.
data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord)
instance MessageC IdleMsg
@ -121,3 +125,40 @@ instance MessageC ModeMsg
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
deriving (Typeable, Show, Eq, Ord)
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

@ -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

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

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

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

@ -51,7 +51,7 @@ cabal-version: >=1.10
library
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
DeriveDataTypeable
DeriveDataTypeable, Trustworthy