Made IRC messages and commands pluggable. Opened up message parsing

hask-irc-core/Network/IRC/Bot.hs

@@ -31,15 +31,15 @@ import Network.IRC.Util
 
 $(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
 
-data Line = Timeout | EOF | Line !UTCTime !Text | Msg Message deriving (Show, Eq)
+data Line = Timeout | EOF | Line !UTCTime !Text | Msg FullMessage deriving (Show, Eq)
 
 sendCommand :: Chan Command -> Command -> IO ()
 sendCommand = writeChan
 
-sendMessage :: Chan Line -> Message -> IO ()
+sendMessage :: Chan Line -> FullMessage -> IO ()
 sendMessage = (. Msg) . writeChan
 
-sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
+sendEvent :: Chan Event -> Event -> IO ()
 sendEvent = writeChan
 
 readLine :: Chan Line -> IO Line
@@ -54,9 +54,9 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
     whenJust mline $ \line -> do
       TF.hprint botSocket "{}\r\n" $ TF.Only line
       infoM . unpack $ "> " ++ line
-    case cmd of
+    case fromCommand cmd of
-      QuitCmd -> latchIt latch
+      Just QuitCmd -> latchIt latch
-      _       -> sendCommandLoop (commandChan, latch) bot
+      _            -> sendCommandLoop (commandChan, latch) bot
 
 readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
 readLineLoop = go []
@@ -83,7 +83,7 @@ readLineLoop = go []
           limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
           let msgParts'' = concat
                            . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
-                           . groupAllOn (msgParserType &&& msgPartTarget) $ msgParts'
+                           . groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
           go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
       where
         readLine' = do
@@ -109,25 +109,18 @@ messageProcessLoop = go 0
           then infoM "Timeout" >> return Disconnected
           else do
             when (status == Kicked) $
-              threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd
+              threadDelay (5 * oneSec) >> sendCommand commandChan (toCommand JoinCmd)
 
             mLine <- readLine lineChan
             case mLine of
-              Timeout      ->
+              Timeout      -> do
-                getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle
+                now <- getCurrentTime
+                dispatchHandlers bot (FullMessage now "" $ toMessage IdleMsg) >> return Idle
               EOF          -> infoM "Connection closed" >> return Disconnected
               Line _ _     -> error "This should never happen"
-              Msg (message@Message { .. }) -> do
+              Msg (msg@FullMessage { .. }) -> do
-                nStatus <- case msgDetails of
+                nStatus <- handleMsg nick message
-                  JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined
+                dispatchHandlers bot msg
-                  KickMsg { .. } | kickedNick == nick    -> infoM "Kicked" >> return Kicked
-                  NickInUseMsg { .. }                    ->
-                    infoM "Nick already in use"     >> return NickNotAvailable
-                  ModeMsg { user = Self, .. }            ->
-                    sendCommand commandChan JoinCmd >> return Connected
-                  _                                      -> return Connected
-
-                dispatchHandlers bot message
                 return nStatus
 
       put nStatus
@@ -145,7 +138,18 @@ messageProcessLoop = go 0
               cmds <- handleMessage msgHandler botConfig message
               forM_ cmds (sendCommand commandChan)
 
-eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
+        handleMsg nick message
+          | Just (JoinMsg user)   <- fromMessage message, userNick user == nick =
+              infoM "Joined" >> return Joined
+          | 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

hask-irc-core/Network/IRC/Client.hs

@@ -38,7 +38,7 @@ $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
 coreMsgHandlerNames :: [MsgHandlerName]
 coreMsgHandlerNames = ["pingpong", "help"]
 
-connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
+connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event)
 connect botConfig@BotConfig { .. } = do
   debugM "Connecting ..."
   socket <- connectToWithRetry
@@ -63,7 +63,7 @@ connect botConfig@BotConfig { .. } = do
 
     newChannel = (,) <$> newChan <*> newEmptyMVar
 
-    mkMsgHandler :: Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
+    mkMsgHandler :: Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler)
     mkMsgHandler eventChan name =
       flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
         case finalHandler of
@@ -80,10 +80,10 @@ connect botConfig@BotConfig { .. } = do
             return hMap
           Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
 
-disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) -> IO ()
+disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) -> IO ()
 disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
   debugM "Disconnecting ..."
-  sendCommand commandChan QuitCmd
+  sendCommand commandChan $ toCommand QuitCmd
   awaitLatch sendLatch
   swapMVar mvBotStatus Disconnected
   awaitLatch readLatch
@@ -125,8 +125,8 @@ runBotIntenal botConfig' = withSocketsDo $ do
         handle handleErrors $ do
           debugM $ "Running with config:\n" ++ show botConfig
 
-          sendCommand commandChan NickCmd
+          sendCommand commandChan $ toCommand NickCmd
-          sendCommand commandChan UserCmd
+          sendCommand commandChan $ toCommand UserCmd
 
           fork $ sendCommandLoop (commandChan, sendLatch) bot
           fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec

hask-irc-core/Network/IRC/Handlers/Core.hs

@@ -21,37 +21,36 @@ mkMsgHandler = MsgHandlerMaker "core" go
 
     helpMsg = "Get help. !help or !help <command>"
 
-pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
+pingPong :: MonadMsgHandler m => IORef UTCTime -> FullMessage -> m [Command]
-pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
+pingPong state FullMessage { .. }
-  io $ atomicWriteIORef state msgTime
+  | Just (PingMsg msg) <- fromMessage message =
-  return [PongCmd msg]
+      io (atomicWriteIORef state msgTime) >> return [toCommand $ PongCmd msg]
-pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
+  | Just (PongMsg _)   <- fromMessage message =
-  io $ atomicWriteIORef state msgTime
+      io (atomicWriteIORef state msgTime) >> return []
-  return []
+  | Just IdleMsg       <- fromMessage message
-pingPong state Message { msgDetails = IdleMsg { .. }, .. }
+  , even (convert msgTime :: Int)             = do
-  | even (convert msgTime :: Int) = do
-    BotConfig { .. } <- ask
-    let limit = fromIntegral $ botTimeout `div` 2
-    io $ do
-      lastComm <- readIORef state
-      if addUTCTime limit lastComm < msgTime
-        then return [PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime]
-        else return []
-
-pingPong _ _ = return []
-
-help :: MonadMsgHandler m => Message -> m [Command]
-help Message { msgDetails = ChannelMsg { .. }, .. }
-  | "!help" == clean msg = do
       BotConfig { .. } <- ask
-      let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
+      let limit = fromIntegral $ botTimeout `div` 2
-      return [ ChannelMsgReply $ "I know these commands: " ++ unwords commands
+      io $ do
-             , ChannelMsgReply "Type !help <command> to know more about any command"]
+        lastComm <- readIORef state
-  | "!help" `isPrefixOf` msg = do
+        return [toCommand . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
-      BotConfig { .. } <- ask
+                | addUTCTime limit lastComm < msgTime]
-      let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
+  | otherwise                                 = return []
-      let mHelp   = find ((\c -> c == command || c == cons '!' command) . fst)
-                    . concatMap mapToList . mapValues $ msgHandlerInfo
-      return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
 
-help _ = return []
+help :: MonadMsgHandler m => FullMessage -> m [Command]
+help FullMessage { .. } = 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
+          , "Type !help <command> to know more about any command"
+          ]
+    | "!help" `isPrefixOf` msg -> do
+        BotConfig { .. } <- ask
+        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]
+  _ -> return []

hask-irc-core/Network/IRC/Internal/Types.hs

@@ -5,36 +5,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Network.IRC.Internal.Types
+module Network.IRC.Internal.Types where
-  (
-    -- * Messages and Commands
-    Nick (..)
-  , User (..)
-  , Message (..)
-  , MessageDetails (..)
-  , Command (..)
-  -- * Events
-  , Event (..)
-  , SomeEvent
-  , EventResponse (..)
-  , QuitEvent(..)
-  -- * Bot
-  , BotConfig (..)
-  , Bot (..)
-  , BotStatus (..)
-  , IRC
-  , runIRC
-  -- * Message handlers
-  , MsgHandlerName
-  , MonadMsgHandler
-  , MsgHandler (..)
-  , newMsgHandler
-  , MsgHandlerMaker (..)
-  , handleMessage
-  , handleEvent
-  , stopMsgHandler
-  , getHelp
-  ) where
 
 import ClassyPrelude
 import Control.Concurrent.Lifted (Chan)
@@ -71,105 +42,211 @@ data User
   } deriving (Show, Eq, Ord)
 
 -- | An IRC message sent from the server to the bot.
-data Message = Message
+data FullMessage = FullMessage
-  { 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.
-  , msgDetails :: MessageDetails   -- ^ The details of the parsed message.
+  , message :: Message   -- ^ The details of the parsed message.
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq)
 
--- | Different types of IRC messages.
+-- | The typeclass for different types of IRC messages.
-data MessageDetails
+class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
-  -- | The internal (non-IRC) message received when the bot is idle.
+  toMessage :: msg -> Message
-  = IdleMsg
+  toMessage = Message
-  -- | The message received when the bot's current nick is already in use.
-  | NickInUseMsg
-  -- | A /PING/ message. Must be replied with a 'PongCmd'.
-  | PingMsg      { msg       :: !Text }
-  -- | A /PONG/ message. Received in response to a 'PingCmd'.
-  | PongMsg      { msg       :: !Text }
-  -- | A /NAMES/ message which contains a list of nicks of all users in the channel.
-  | NamesMsg     { nicks     :: ![Nick] }
-  -- | A /PRIVMSG/ message sent to the channel from a user.
-  | ChannelMsg   { user      :: !User, msg        :: !Text }
-  -- | A /PRIVMSG/ private message sent to the bot from a user.
-  | PrivMsg      { user      :: !User, msg        :: !Text }
-  -- | An /PRIVMSG/ action message sent to the channel from a user.
-  | ActionMsg    { user      :: !User, msg        :: !Text }
-  -- | A /JOIN/ message received when a user joins the channel.
-  | JoinMsg      { user      :: !User }
-  -- | A /QUIT/ message received when a user quits the server.
-  | QuitMsg      { user      :: !User, msg        :: !Text }
-  -- | A /PART/ message received when a user leaves the channel.
-  | PartMsg      { user      :: !User, msg        :: !Text }
-  -- | A /NICK/ message received when a user changes their nick.
-  | NickMsg      { user      :: !User, newNick    :: !Nick }
-  -- | A /KICK/ message received when a user kicks another user from the channel.
-  | KickMsg      { user      :: !User, kickedNick :: !Nick, msg       :: !Text }
-  -- | A /MODE/ message received when a user's mode changes.
-  | ModeMsg      { user      :: !User, msgTarget  :: !Text, mode      :: !Text , modeArgs :: ![Text] }
-  -- | All other messages which are not parsed as any of the above types.
-  | OtherMsg     { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg      :: !Text }
-  deriving (Show, Eq, Ord)
 
--- | IRC commands sent from the bot to the server.
+  fromMessage :: Message -> Maybe msg
-data Command
+  fromMessage (Message msg) = cast msg
-  -- | A /PING/ command. A 'PongMsg' is expected as a response to this.
+
-  = PingCmd         { rmsg  :: !Text }
+-- | A wrapper over all types of IRC messages.
-  -- | A /PONG/ command. Sent in response to a 'PingMsg'.
+data Message = forall m . MessageC m => Message m deriving (Typeable)
-  | PongCmd         { rmsg  :: !Text }
+instance Show Message where
-  -- | A /PRIVMSG/ message sent to the channel.
+  show (Message m) = show m
-  | ChannelMsgReply { rmsg  :: !Text }
+instance Eq Message where
-  -- | A /PRIVMSG/ message sent to a user.
+  Message m1 == Message m2 = case cast m1 of
-  | PrivMsgReply    { ruser :: !User, rmsg :: !Text }
+    Just m1' -> m1' == m2
-  -- | A /NICK/ command sent to set the bot's nick.
+    _        -> False
-  | NickCmd
+
-  -- | A /USER/ command sent to identify the bot.
+-- | The internal (non-IRC) message received when the bot is idle.
-  | UserCmd
+data IdleMsg      = IdleMsg deriving (Typeable, Show, Eq, Ord)
-  -- | A /JOIN/ command sent to join the channel.
+instance MessageC IdleMsg
-  | JoinCmd
+
-  -- | A /QUIT/ command sent to quit the server.
+-- | The message received when the bot's current nick is already in use.
-  | QuitCmd
+data NickInUseMsg = NickInUseMsg deriving (Typeable, Show, Eq, Ord)
-  -- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
+instance MessageC NickInUseMsg
-  | NamesCmd
+
-  deriving (Show, Eq, Ord)
+-- | A /PING/ message. Must be replied with a 'PongCmd'.
+data PingMsg      = PingMsg !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC PingMsg
+
+-- | A /PONG/ message. Received in response to a 'PingCmd'.
+data PongMsg      = PongMsg !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC PongMsg
+
+-- | A /NAMES/ message which contains a list of nicks of all users in the channel.
+data NamesMsg     = NamesMsg ![Nick] deriving (Typeable, Show, Eq, Ord)
+instance MessageC NamesMsg
+
+-- | A /PRIVMSG/ message sent to the channel from a user.
+data ChannelMsg   = ChannelMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC ChannelMsg
+
+-- | A /PRIVMSG/ private message sent to the bot from a user.
+data PrivMsg      = PrivMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC PrivMsg
+
+-- | An /PRIVMSG/ action message sent to the channel from a user.
+data ActionMsg    = ActionMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC ActionMsg
+
+-- | A /JOIN/ message received when a user joins the channel.
+data JoinMsg      = JoinMsg !User deriving (Typeable, Show, Eq, Ord)
+instance MessageC JoinMsg
+
+-- | A /QUIT/ message received when a user quits the server.
+data QuitMsg      = QuitMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC QuitMsg
+
+-- | A /PART/ message received when a user leaves the channel.
+data PartMsg      = PartMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC PartMsg
+
+-- | A /NICK/ message received when a user changes their nick.
+data NickMsg      = NickMsg !User !Nick deriving (Typeable, Show, Eq, Ord)
+instance MessageC NickMsg
+
+-- | A /KICK/ message received when a user kicks another user from the channel.
+data KickMsg      = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :: !Text }
+               deriving (Typeable, Show, Eq, Ord)
+instance MessageC KickMsg
+
+-- | A /MODE/ message received when a user's mode changes.
+data ModeMsg      = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
+               deriving (Typeable, Show, Eq, Ord)
+instance MessageC ModeMsg
+
+-- | All other messages which are not parsed as any of the above types.
+data OtherMsg     = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
+                deriving (Typeable, Show, Eq, Ord)
+instance MessageC OtherMsg
+
+-- | 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
+
+-- ** Message Parsing
+
+-- | Message parser id. Should be unique.
+type MessageParserId = Text
+
+-- | A part of a mutlipart message.
+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.
+  deriving (Eq, Show)
+
+-- | A message parser.
+data MessageParser = MessageParser
+  { msgParserId :: !MessageParserId
+  , msgParser   :: !(BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult)
+  }
 
 -- ** 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) => Event e where
+class (Typeable e, Show e, Eq e) => EventC e where
   -- | Creates an event.
-  toEvent :: e -> IO SomeEvent
+  toEvent :: e -> IO Event
-  toEvent e = SomeEvent <$> pure e <*> getCurrentTime
+  toEvent e = Event <$> pure e <*> getCurrentTime
 
   -- | Extracts a received event.
-  fromEvent :: SomeEvent -> Maybe (e, UTCTime)
+  fromEvent :: Event -> Maybe (e, UTCTime)
-  fromEvent (SomeEvent e time) = do
+  fromEvent (Event e time) = do
     ev <- cast e
     return (ev, time)
 
--- | A wrapper over all events to allow sending them over channel of same type.
+-- | A wrapper over all types of 'Event's to allow sending them over channel of same type.
-data SomeEvent = forall e. (Event e, Typeable e) => SomeEvent e UTCTime deriving (Typeable)
+data Event = forall e. (EventC e, Typeable e) => Event e UTCTime deriving (Typeable)
-instance Show SomeEvent where
+instance Show Event where
-  show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
+  show (Event e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
-instance Eq SomeEvent where
+instance Eq Event where
-  SomeEvent e1 t1 == SomeEvent e2 t2 =
+  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
+data EventResponse =
-  = RespNothing            -- ^ No response
+  -- | No response
-  | RespEvent [SomeEvent]  -- ^ Events as the response. They will be sent to all message handlers like usual events.
+    RespNothing
-  | RespMessage [Message]  -- ^ Messages as the response. They will be sent to all message handlers like usual messages.
+  -- | Events as the response. They will be sent to all message handlers like usual events.
-  | RespCommand [Command]  -- ^ Commands as the response. They will be sent to the server like usual commands.
+  | 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 Event QuitEvent
+instance EventC QuitEvent
 
 -- ** Bot
 
@@ -195,6 +272,8 @@ data BotConfig = BotConfig
   , msgHandlerInfo   :: !(Map MsgHandlerName (Map Text Text))
   -- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot.
   , msgHandlerMakers :: ![MsgHandlerMaker]
+  -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
+  , msgParsers       :: ![MessageParser]
   -- | All the bot configuration so that message handlers can lookup their own specific configs.
   , config           :: !Config
   }
@@ -260,20 +339,20 @@ newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
 
 -- | The monad in which message handlers actions run.
 class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => MonadMsgHandler m where
-  msgHandler :: MsgHandlerT a -> m a
+  fromMsgHandler :: MsgHandlerT a -> m a
 
 instance MonadMsgHandler MsgHandlerT where
-  msgHandler = id
+  fromMsgHandler = id
 
 -- | A message handler containing actions which are invoked by the bot.
 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 => Message -> m [Command])
+    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 => SomeEvent -> m EventResponse)
+  , onEvent   :: !(forall m . MonadMsgHandler m => Event -> m EventResponse)
   -- | The action invoked to stop the message handler.
   , 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.
@@ -295,7 +374,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 SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler))
+  , msgHandlerMaker :: !(BotConfig -> Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler))
   }
 
 instance Eq MsgHandlerMaker where
@@ -306,7 +385,7 @@ instance Ord MsgHandlerMaker where
 -- | Handles a message using a given message handler.
 handleMessage :: MsgHandler    -- ^ The message handler.
               -> BotConfig     -- ^ The bot config.
-              -> Message       -- ^ The message to handle.
+              -> FullMessage   -- ^ The message to handle.
               -> IO [Command]  -- ^ A list of commands to be sent to the server.
 handleMessage MsgHandler { .. } botConfig =
   flip runReaderT botConfig . _runMsgHandler . onMessage
@@ -314,7 +393,7 @@ handleMessage MsgHandler { .. } botConfig =
 -- | Handles an event using a given message handler.
 handleEvent :: MsgHandler        -- ^ The message handler.
             -> BotConfig         -- ^ The bot config.
-            -> SomeEvent         -- ^ The event to handle.
+            -> 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

hask-irc-core/Network/IRC/Protocol.hs

@@ -9,100 +9,106 @@ import Data.Text (strip)
 
 import Network.IRC.Types
 
-data MessageParseType = Names
+parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
-                        deriving (Show, Eq)
+parseLine botConfig@BotConfig { .. } time line msgParts =
-
+  fromMaybe (Nothing, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult MessageParser { .. } ->
-data MessagePart = MessagePart { msgParserType :: MessageParseType
-                               , msgPartTarget :: Text
-                               , msgPartTime   :: UTCTime
-                               , msgPartLine   :: Text }
-                   deriving (Show, Eq)
-
-data MessageParseResult =  Done Message [MessagePart]
-                         | Partial [MessagePart]
-                         | Reject
-                         deriving (Show, Eq)
-
-type MessageParser = BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult
-
-parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
-parseLine botConfig time line msgParts =
-  fromMaybe (Nothing, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult parser ->
     case parseResult of
       Just _  -> parseResult
-      Nothing -> case parser botConfig time line msgParts of
+      Nothing -> let
-                   Reject                  -> Nothing
+        (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
-                   Partial msgParts'       -> Just (Nothing, msgParts')
+        in case msgParser botConfig time line parserMsgParts of
-                   Done message' msgParts' -> Just (Just message', msgParts')
+             Reject                  -> Nothing
+             Partial msgParts'       -> Just (Nothing, msgParts' ++ otherParserMsgParts)
+             Done message' msgParts' -> Just (Just message', msgParts' ++ otherParserMsgParts)
   where
-    parsers = [pingParser, namesParser, lineParser]
+    parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
 
 pingParser :: MessageParser
-pingParser _ time line msgParts
+pingParser = MessageParser "ping" go
-  | "PING :" `isPrefixOf` line = Done (Message time line . PingMsg . drop 6 $ line) msgParts
+  where
-  | otherwise                  = Reject
+    go _ time line _
+      | "PING :" `isPrefixOf` line = Done (FullMessage time line . toMessage . PingMsg . drop 6 $ line) []
+      | otherwise                  = Reject
 
-lineParser :: MessageParser
+parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
-lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message time line $
+parseMsgLine line = (splits, command, source, target, message)
-  case command of
-    "PONG"    -> PongMsg message
-    "JOIN"    -> JoinMsg user
-    "QUIT"    -> QuitMsg user quitMessage
-    "PART"    -> PartMsg user message
-    "KICK"    -> KickMsg user (Nick kicked) kickReason
-    "MODE"    -> if Nick source == botNick
-                   then ModeMsg Self target message []
-                   else ModeMsg user target mode modeArgs
-    "NICK"    -> NickMsg user $ Nick (drop 1 target)
-    "433"     -> NickInUseMsg
-    "PRIVMSG" | target /= channel -> PrivMsg user message
-              | isActionMsg       -> ActionMsg user (initDef . drop 8 $ message)
-              | otherwise         -> ChannelMsg user message
-    _         -> OtherMsg source command target message
   where
     splits      = words line
     command     = splits !! 1
     source      = drop 1 $ splits !! 0
     target      = splits !! 2
     message     = strip . drop 1 . unwords . drop 3 $ splits
-    quitMessage = strip . drop 1 . unwords . drop 2 $ splits
-    user        = uncurry User . (Nick *** drop 1) . break (== '!') $ source
-    mode        = splits !! 3
-    modeArgs    = drop 4 splits
-    kicked      = splits !! 3
-    kickReason  = drop 1 . unwords . drop 4 $ splits
-    isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
 
-partitionMsgParts :: MessageParseType -> Text -> [MessagePart] -> ([MessagePart], [MessagePart])
+lineParser :: MessageParser
-partitionMsgParts parserType target =
+lineParser = MessageParser "line" go
-  partition (\MessagePart { .. } -> msgParserType == parserType && msgPartTarget == target)
+  where
+    go BotConfig { .. } time line _ =
+      case command of
+        "PONG"    -> done $ toMessage $ PongMsg message
+        "JOIN"    -> done $ toMessage $ JoinMsg user
+        "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
+                       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
+        _         -> Reject
+      where
+        done = flip Done [] . FullMessage time line
+
+        (splits, command, source, target, message) = parseMsgLine line
+        quitMessage = strip . drop 1 . unwords . drop 2 $ splits
+        user        = uncurry User . (Nick *** drop 1) . break (== '!') $ source
+        mode        = splits !! 3
+        modeArgs    = drop 4 splits
+        kicked      = splits !! 3
+        kickReason  = drop 1 . unwords . drop 4 $ splits
+        isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
+
+defaultParser :: MessageParser
+defaultParser = MessageParser "default" go
+  where
+    go _ time line _ = flip Done [] . FullMessage time line $
+      toMessage $ OtherMsg source command target message
+      where
+        (_, command, source, target, message) = parseMsgLine line
 
 namesParser :: MessageParser
-namesParser BotConfig { .. } time line msgParts = case command of
+namesParser = MessageParser "names" go
-  "353" -> Partial $ MessagePart Names target time line : msgParts
-  "366" -> let
-    (myMsgParts, otherMsgParts) = partitionMsgParts Names target msgParts
-    (nicks, allLines) =  concat *** intercalate "\r\n" . (++ [line])
-      $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
-    in Done (Message time allLines $ NamesMsg nicks) otherMsgParts
-  _     -> Reject
   where
-    (_ : command : target : _) = words line
+    go BotConfig { .. } time line msgParts = case command of
-    stripNickPrefix  = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
+      "353" -> Partial $ MessagePart "names" target time line : msgParts
-    namesNicks line' =
+      "366" -> let
-      map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
+        (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
+      _     -> Reject
+      where
+        (_ : command : target : _) = words line
+        stripNickPrefix  = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
+        namesNicks line' =
+          map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
 
 lineFromCommand :: BotConfig -> Command -> Maybe Text
-lineFromCommand BotConfig { .. } command = case command of
+lineFromCommand BotConfig { .. } command
-  PongCmd { .. }                  -> Just $ "PONG :" ++ rmsg
+  | Just (PongCmd msg)                    <- fromCommand command = Just $ "PONG :" ++ msg
-  PingCmd { .. }                  -> Just $ "PING :" ++ rmsg
+  | Just (PingCmd msg)                    <- fromCommand command = Just $ "PING :" ++ msg
-  NickCmd                         -> Just $ "NICK " ++ botNick'
+  | Just NickCmd                          <- fromCommand command = Just $ "NICK " ++ botNick'
-  UserCmd                         -> Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
+  | Just UserCmd                          <- fromCommand command =
-  JoinCmd                         -> Just $ "JOIN " ++ channel
+      Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
-  QuitCmd                         -> Just "QUIT"
+  | Just JoinCmd                          <- fromCommand command = Just $ "JOIN " ++ channel
-  ChannelMsgReply { .. }          -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
+  | Just QuitCmd                          <- fromCommand command = Just "QUIT"
-  PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg
+  | Just (ChannelMsgReply msg)            <- fromCommand command =
-  NamesCmd                        -> Just $ "NAMES " ++ channel
+      Just $ "PRIVMSG " ++ channel ++ " :" ++ msg
-  _                               -> Nothing
+  | Just (PrivMsgReply (User { .. }) msg) <- fromCommand command =
+      Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
+  | Just NamesCmd                         <- fromCommand command = Just $ "NAMES " ++ channel
+  | otherwise = Nothing
   where
     botNick' = nickToText botNick

hask-irc-core/Network/IRC/Types.hs

@@ -10,15 +10,47 @@ Portability : POSIX
 
 module Network.IRC.Types
   (
-    -- * IRC related
+  -- * IRC Messages
     Nick (..)
   , User (..)
-  , Message (..)
+  , MessageC (..)
-  , MessageDetails (..)
+  , Message
-  , Command (..)
+  , FullMessage (..)
+  , IdleMsg (..)
+  , NickInUseMsg (..)
+  , PingMsg (..)
+  , PongMsg (..)
+  , NamesMsg (..)
+  , ChannelMsg (..)
+  , PrivMsg (..)
+  , ActionMsg (..)
+  , JoinMsg (..)
+  , QuitMsg (..)
+  , PartMsg (..)
+  , NickMsg (..)
+  , KickMsg (..)
+  , ModeMsg (..)
+  , OtherMsg (..)
+  -- * IRC Commands
+  , CommandC (..)
+  , Command
+  , PingCmd (..)
+  , PongCmd (..)
+  , ChannelMsgReply (..)
+  , PrivMsgReply (..)
+  , NickCmd (..)
+  , UserCmd (..)
+  , JoinCmd (..)
+  , QuitCmd (..)
+  , NamesCmd (..)
+  -- * Message Parsing
+  , MessageParserId
+  , MessagePart (..)
+  , MessageParseResult (..)
+  , MessageParser (..)
   -- * Events
-  , Event (..)
+  , EventC (..)
-  , SomeEvent
+  , Event
   , EventResponse (..)
   , QuitEvent(..)
   -- * Bot

hask-irc-core/hask-irc-core.cabal

@@ -81,4 +81,4 @@ library
 
   default-language:    Haskell2010
 
-  ghc-options:         -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields -fno-warn-orphans
+  ghc-options:         -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans

hask-irc-handlers/Network/IRC/Handlers/Auth.hs

@@ -42,10 +42,11 @@ issueToken acid user = do
 
 -- handler
 
-authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m [Command]
+authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage ->  m [Command]
-authMessage state Message { msgDetails = PrivMsg { .. }, .. }
+authMessage state FullMessage { .. }
-  | "token" `isPrefixOf` msg = map (singleton . PrivMsgReply user) . io $
+  | Just (PrivMsg user msg) <- fromMessage message
-      readIORef state >>= flip issueToken (userNick user)
+  , "token" `isPrefixOf` msg =
+      map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user)
 authMessage _ _ = return []
 
 stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
@@ -54,7 +55,7 @@ stopAuth state = io $ do
   createArchive acid
   createCheckpointAndClose acid
 
-authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> SomeEvent -> m EventResponse
+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

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

@@ -4,10 +4,10 @@
 module Network.IRC.Handlers.Auth.Types where
 
 import ClassyPrelude
-import Data.Data      (Data)
+import Data.Data     (Data)
-import Data.SafeCopy  (base, deriveSafeCopy)
+import Data.SafeCopy (base, deriveSafeCopy)
 
-import Network.IRC.Types hiding (user)
+import Network.IRC.Types
 
 type Token   = Text
 newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
@@ -19,7 +19,7 @@ $(deriveSafeCopy 0 'base ''Auth)
 
 data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable)
 
-instance Event AuthEvent
+instance EventC AuthEvent
 
 instance Show AuthEvent where
   show (AuthEvent nick token _) =

hask-irc-handlers/Network/IRC/Handlers/Greet.hs

@@ -13,22 +13,22 @@ greetMsgHandlerMaker = MsgHandlerMaker "greeter" go
     go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
     go _ _ _          = return Nothing
 
-greeter ::  MonadMsgHandler m => Message -> m [Command]
+greeter ::  MonadMsgHandler m => FullMessage -> m [Command]
-greeter Message { msgDetails = ChannelMsg { .. }, .. } =
+greeter FullMessage { .. } = case fromMessage message of
-  return . maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
+  Just (ChannelMsg user msg) ->
-    . find (== clean msg) $ greetings
+    return . maybeToList . map (toCommand . ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
+      . find (== clean msg) $ greetings
+  _                          -> return []
   where
     greetings = [ "hi", "hello", "hey", "sup", "bye"
                 , "good morning", "good evening", "good night" ]
-greeter _ = return []
 
-welcomer :: MonadMsgHandler m => Message -> m [Command]
+welcomer :: MonadMsgHandler m => FullMessage -> m [Command]
-welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
+welcomer FullMessage { .. } = case fromMessage message of
-  BotConfig { .. } <- ask
+  Just (JoinMsg user) -> do
-  if userNick user /= botNick
+    BotConfig { .. } <- ask
-    then return [ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)]
+    return [toCommand . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
-    else return []
+            | userNick user /= botNick]
-
+  _                   -> return []
-welcomer _ = return []
 
 

hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs

@@ -73,17 +73,25 @@ withLogFile action state = do
 
   return []
 
-messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Command]
+messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command]
-messageLogger Message { .. } = case msgDetails of
+messageLogger FullMessage { .. }
-  ChannelMsg { .. } -> log "<{}> {}"                  [nick user, msg]
+  | Just (ChannelMsg user msg) <- fromMessage message =
-  ActionMsg { .. }  -> log "<{}> {} {}"               [nick user, nick user, msg]
+      log "<{}> {}" [nick user, msg]
-  KickMsg { .. }    -> log "** {} KICKED {} :{}"      [nick user, nickToText kickedNick, msg]
+  | Just (ActionMsg user msg) <- fromMessage message =
-  JoinMsg { .. }    -> log "** {} JOINED"             [nick user]
+      log "<{}> {} {}" [nick user, nick user, msg]
-  PartMsg { .. }    -> log "** {} PARTED :{}"         [nick user, msg]
+  | Just (KickMsg user kickedNick msg) <- fromMessage message =
-  QuitMsg { .. }    -> log "** {} QUIT :{}"           [nick user, msg]
+      log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg]
-  NickMsg { .. }    -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
+  | Just (JoinMsg user) <- fromMessage message =
-  NamesMsg { .. }   -> log "** USERS {}"              [unwords . map nickToText $ nicks]
+      log "** {} JOINED" [nick user]
-  _                 -> const $ return []
+  | Just (PartMsg user msg) <- fromMessage message =
+      log "** {} PARTED :{}" [nick user, msg]
+  | Just (QuitMsg user msg) <- fromMessage message =
+      log "** {} QUIT :{}" [nick user, msg]
+  | Just (NickMsg user newNick) <- fromMessage message =
+      log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
+  | Just (NamesMsg nicks) <- fromMessage message =
+      log "** USERS {}" [unwords . map nickToText $ nicks]
+  | otherwise = const $ return []
   where
     nick = nickToText . userNick
 

hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs

@@ -54,47 +54,49 @@ data NickTrackingState = NickTrackingState { acid            :: AcidState NickTr
                                            , onlineNicks     :: HashSet Nick
                                            , lastRefreshOn   :: UTCTime }
 
-nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m [Command]
+nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> FullMessage ->  m [Command]
-nickTrackerMsg state message@Message { .. } = case msgDetails of
+nickTrackerMsg state FullMessage { .. }
-  ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
+  | Just (ChannelMsg (User { .. }) msg)  <- fromMessage message =
-  ActionMsg { .. }  -> updateNickTrack state user msg msgTime >> return []
+      updateNickTrack state userNick msg msgTime >> handleCommands userNick msg
-  JoinMsg { .. }    -> updateNickTrack state user "" msgTime  >> add user    >> return []
+  | Just (ActionMsg (User { .. }) msg)   <- fromMessage message =
-  PartMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
+      updateNickTrack state userNick msg msgTime >> return []
-  QuitMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
+  | Just (JoinMsg (User { .. }))         <- fromMessage message =
-  NickMsg { .. }    ->
+      updateNickTrack state userNick "" msgTime  >> add userNick    >> return []
-    handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return []
+  | Just (PartMsg (User { .. }) msg)     <- fromMessage message =
-  NamesMsg { .. }   -> do
+      updateNickTrack state userNick msg msgTime >> remove userNick >> return []
-    forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
+  | Just (QuitMsg (User { .. }) msg)     <- fromMessage message =
-    refresh nicks >> updateRefreshTime >> return []
+      updateNickTrack state userNick msg msgTime >> remove userNick >> return []
-  IdleMsg { .. }    -> do
+  | Just (NickMsg (User { .. }) newNick) <- fromMessage message =
-    NickTrackingState { .. } <- readIORef state
+      handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return []
-    if addUTCTime refreshInterval lastRefreshOn < msgTime
+  | Just (NamesMsg nicks) <- fromMessage message       = do
-      then updateRefreshTime >> return [NamesCmd]
+      forM_ nicks $ \n -> updateNickTrack state n "" msgTime
-      else return []
+      refresh nicks >> updateRefreshTime >> return []
-  _                 -> return []
+  | Just IdleMsg                <- fromMessage message = do
+      NickTrackingState { .. } <- readIORef state
+      if addUTCTime refreshInterval lastRefreshOn < msgTime
+        then updateRefreshTime >> return [toCommand NamesCmd]
+        else return []
+  | otherwise                                          = return []
   where
     updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
 
     modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s }
-    add        = modifyOnlineNicks . flip ((. userNick) . flip insertSet)
+    add                 = modifyOnlineNicks . insertSet
-    remove     = modifyOnlineNicks . flip ((. userNick) . flip deleteSet)
+    remove              = modifyOnlineNicks . deleteSet
-    swap users = modifyOnlineNicks $
+    swap (oNick, nNick) = modifyOnlineNicks $ deleteSet oNick . insertSet nNick
-      let (oNick, nNick) = both userNick users
+    refresh             = modifyOnlineNicks . const . setFromList
-      in deleteSet oNick . insertSet nNick
-    refresh    = modifyOnlineNicks . const . setFromList
 
     commands = [ ("!nicks",       handleNickCommand)
                , ("!seen",        handleSeenCommand)
                , ("!forgetnicks", handleForgetNicksCommand)]
 
-    handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
+    handleCommands nick msg = case find ((`isPrefixOf` msg) . fst) commands of
       Nothing           -> return []
-      Just (_, handler) -> handler state message
+      Just (_, handler) -> handler state nick msg
 
-updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
+updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m ()
-updateNickTrack state user message msgTime = io $ do
+updateNickTrack state nck message msgTime = io $ do
   NickTrackingState { .. } <- readIORef state
-  let nck = userNick user
   mnt     <- getByNick acid nck
   (message', lastMessageOn', cn) <- case (message, mnt) of
     ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
@@ -103,10 +105,9 @@ updateNickTrack state user message msgTime = io $ do
 
   saveNickTrack acid $ NickTrack nck cn msgTime lastMessageOn' message'
 
-handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> User -> Nick -> UTCTime -> m ()
+handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m ()
-handleNickChange state user newNick msgTime = io $ do
+handleNickChange state prevNick newNick msgTime = io $ do
   NickTrackingState { .. } <- readIORef state
-  let prevNick = userNick user
   mpnt         <- getByNick acid prevNick
   mnt          <- getByNick acid newNick
   mInfo        <- case (mpnt, mnt) of
@@ -125,27 +126,28 @@ newCanonicalNick :: IO CanonicalNick
 newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
 
 withNickTracks :: MonadMsgHandler m
-               => (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
+               => (Text -> [NickTrack] -> HashSet Nick -> IO Text)
+               -> IORef NickTrackingState -> Nick -> Text
                -> m [Command]
-withNickTracks f state message = io $ do
+withNickTracks f state _ msg = io $ do
   NickTrackingState { .. } <- readIORef state
-  let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
+  let nick = clean . unwords . drop 1 . words $ msg
   if nick == ""
     then return []
     else do
       mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
-      map (singleton . ChannelMsgReply) $ case mcn of
+      map (singleton . toCommand . ChannelMsgReply) $ case mcn of
         Nothing -> return $ "Unknown nick: " ++ nick
         Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
 
-handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
+handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
 handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
   let nicks = map ((\(Nick n) -> n) . nick) nickTracks
   return . (nck ++) $ if length nicks == 1
     then " has only one nick"
     else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
 
-handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
+handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
 handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
   let NickTrack { lastSeenOn = lastSeenOn'
                 , nick       = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
@@ -163,17 +165,16 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
       (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
       " said: " ++ lastMessage')
 
-handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
+handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
-handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
+handleForgetNicksCommand state nick _ = do
   NickTrackingState { .. } <- readIORef state
-  let nick = userNick user
   io $ do
     Just nt <- getByNick acid nick
     cn      <- newCanonicalNick
     saveNickTrack acid $ nt { canonicalNick = cn }
-  return [ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
+  return [toCommand . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
 
-nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> SomeEvent -> m EventResponse
+nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> Event -> m EventResponse
 nickTrackerEvent state event = case fromEvent event of
   Just (NickTrackRequest nick reply, _) -> io $ do
     NickTrackingState { .. } <- readIORef state

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

@@ -40,12 +40,12 @@ emptyNickTracking = NickTracking empty
 
 data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
 
-instance Event NickTrackRequest
+instance EventC NickTrackRequest
 
 instance Show NickTrackRequest where
   show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
 
-getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
+getCanonicalNick :: Chan Event -> Nick -> IO (Maybe CanonicalNick)
 getCanonicalNick eventChan nick = do
   reply   <- newEmptyMVar
   request <- toEvent $ NickTrackRequest nick reply

hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs

@@ -38,14 +38,15 @@ instance FromJSON Song where
     parseJSON a | a == emptyArray = return NoSong
     parseJSON _                   = mempty
 
-songSearch :: MonadMsgHandler m => Message -> m [Command]
+songSearch :: MonadMsgHandler m => FullMessage -> m [Command]
-songSearch Message { msgDetails = ChannelMsg { .. }, .. }
+songSearch FullMessage { .. }
-  | "!m " `isPrefixOf` msg = do
+  | Just (ChannelMsg _ msg) <- fromMessage message
+  , "!m " `isPrefixOf` msg = do
       BotConfig { .. } <- ask
       liftIO $ do
         let query = strip . drop 3 $ msg
         mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
-        map (singleton . ChannelMsgReply) $ case mApiKey of
+        map (singleton . toCommand . ChannelMsgReply) $ case mApiKey of
           Nothing     -> do
             errorM "tinysong api key not found in config"
             return $ "Error while searching for " ++ query
@@ -54,10 +55,11 @@ songSearch Message { msgDetails = ChannelMsg { .. }, .. }
                           ++ "?format=json&key=" ++ apiKey
 
             result <- try $ curlAesonGet apiUrl >>= evaluate
-            return $ case result of
+            case result of
-              Left (_ :: CurlAesonException) -> "Error while searching for " ++ query
+              Left (e :: CurlAesonException) -> do
-              Right song                     -> case song of
+                errorM . unpack $ "Error while searching for " ++ query ++ ": " ++ pack (show e)
+                return $ "Error while searching for " ++ query
+              Right song                     -> return $ case song of
                 Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
                 NoSong      -> "No song found for: " ++ query
   | otherwise              = return []
-songSearch _ = return []

hask-irc-handlers/Network/IRC/Handlers/Tell.hs

@@ -47,20 +47,21 @@ saveTell acid = update acid . SaveTellQ
 
 newtype TellState = TellState { acid :: AcidState Tells }
 
-tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message ->  m [Command]
+tellMsg :: MonadMsgHandler m => Chan Event -> IORef TellState -> FullMessage ->  m [Command]
-tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
+tellMsg eventChan state FullMessage { .. }
-  | command == "!tell"
+  | Just (ChannelMsg (User { .. }) msg) <- fromMessage message
+  , command msg == "!tell"
   , args <- drop 1 . words $ msg
   , length args >= 2             = io $ do
       TellState { .. } <- readIORef state
       reps <- if "<" `isPrefixOf` headEx args
         then do -- multi tell
-          let (nicks, message) =
+          let (nicks, tell) =
                 (parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
-          if null message
+          if null tell
             then return []
             else do
-              res <- forM nicks $ \nick -> handleTell acid nick message
+              res <- forM nicks $ \nick -> handleTell acid nick tell
               let (fails, passes) = partitionEithers res
               let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
                            (if null passes then [] else
@@ -68,33 +69,35 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
               return reps
         else do -- single tell
           let nick = Nick . headEx $ args
-          let message = strip . unwords . drop 1 $ args
+          let tell = strip . unwords . drop 1 $ args
-          if null message
+          if null tell
             then return []
             else do
-              res <- handleTell acid nick message
+              res <- handleTell acid nick tell
               let rep = case res of
                           Left _  -> "Unknown nick: " ++ nickToText nick
                           Right _ -> "Message noted and will be passed on to " ++ nickToText nick
               return [rep]
-      tells <- getTellsToDeliver
+      tells <- getTellsToDeliver userNick
-      return . map textToReply $ (reps ++ tells)
+      return . map (textToReply userNick) $ (reps ++ tells)
-  | otherwise                    = io $ map (map textToReply) getTellsToDeliver
+  | Just (ChannelMsg (User { .. }) _) <- fromMessage message =
+      io $ map (map (textToReply userNick)) $ getTellsToDeliver userNick
+  | otherwise = return []
   where
-    command = clean . fromMaybe "" $ headMay . words $ msg
+    command msg = clean . fromMaybe "" . headMay . words $ msg
 
     parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
 
-    textToReply t = ChannelMsgReply $ nickToText (userNick user) ++ ": " ++ t
+    textToReply nick t = toCommand . ChannelMsgReply $ nickToText nick ++ ": " ++ t
 
     tellToMsg Tell { .. } =
       relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
 
-    newTell canonicalNick = Tell (-1) (userNick user) canonicalNick Nothing NewTell msgTime Nothing
+    newTell nick canonicalNick = Tell (-1) nick canonicalNick Nothing NewTell msgTime Nothing
 
-    getTellsToDeliver = io $ do
+    getTellsToDeliver nick = io $ do
       TellState { .. } <- readIORef state
-      mcn              <- getCanonicalNick eventChan $ userNick user
+      mcn              <- getCanonicalNick eventChan nick
       case mcn of
         Nothing            -> return []
         Just canonicalNick -> do
@@ -103,19 +106,17 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
             saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
             return . tellToMsg $ tell
 
-    handleTell acid nick message = do
+    handleTell acid nick tell = do
       mcn <- getCanonicalNick eventChan nick
       case mcn of
         Nothing            -> return . Left . nickToText $ nick
         Just canonicalNick ->
-          saveTell acid (newTell canonicalNick message) >> (return . Right . nickToText $ nick)
+          saveTell acid (newTell nick canonicalNick tell) >> (return . Right . nickToText $ nick)
 
-tellMsg _ _ _ = return []
+tellEvent :: MonadMsgHandler m => Chan Event -> IORef TellState -> Event -> m EventResponse
-
-tellEvent :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> SomeEvent -> m EventResponse
 tellEvent eventChan state event = case fromEvent event of
   Just (TellRequest user message, evTime) -> do
-    tellMsg eventChan state . Message evTime "" $ ChannelMsg user message
+    tellMsg eventChan state . FullMessage evTime "" . toMessage $ ChannelMsg user message
     return RespNothing
   _                                       -> return RespNothing
 

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

@@ -44,11 +44,11 @@ emptyTells = Tells (TellId 1) empty
 
 data TellRequest = TellRequest User Text deriving (Eq, Typeable)
 
-instance Event TellRequest
+instance EventC TellRequest
 
 instance Show TellRequest where
   show (TellRequest user tell) =
     "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
 
-sendTell :: Chan SomeEvent -> User -> Text -> IO ()
+sendTell :: Chan Event -> User -> Text -> IO ()
 sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan

hask-irc-handlers/hask-irc-handlers.cabal

@@ -91,4 +91,4 @@ library
 
   default-language:    Haskell2010
 
-  ghc-options:         -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields -fno-warn-orphans
+  ghc-options:         -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans

hask-irc-runner/Network/IRC/Config.hs

@@ -31,6 +31,7 @@ loadBotConfig configFile = do
           CF.require cfg "timeout"         <*>
           pure handlerInfo                 <*>
           pure allMsgHandlerMakers         <*>
+          pure []                          <*>
           pure cfg
 
       case eBotConfig of

hask-irc-runner/hask-irc-runner.cabal

@@ -72,5 +72,5 @@ executable hask-irc
   -- Base language which the package is written in.
   default-language:    Haskell2010
 
-  ghc-options:         -O2 -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans
+  ghc-options:         -O2 -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -threaded