Even more refactoring

Network/IRC/Bot.hs

@@ -12,7 +12,7 @@ module Network.IRC.Bot
   , eventProcessLoop )
 where
 
-import qualified Data.Text.Format as TF
+import qualified Data.Text.Format  as TF
 import qualified System.Log.Logger as HSL
 
 import ClassyPrelude
@@ -97,10 +97,11 @@ messageProcessLoop lineChan commandChan !idleFor = do
 
         mLine <- readLine lineChan
         case mLine of
-          Timeout      -> getCurrentTime >>= dispatchHandlers bot . IdleMsg  >> return Idle
+          Timeout      ->
+            getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg)  >> return Idle
           EOF          -> infoM "Connection closed" >> return Disconnected
-          Line message -> do
+          Line (message@Message { .. }) -> do
-            nStatus <- case message of
+            nStatus <- case msgDetails of
               JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined
               KickMsg { .. } | kickedNick == nick    -> infoM "Kicked" >> return Kicked
               NickInUseMsg { .. }                    ->

Network/IRC/Handlers.hs

@@ -35,31 +35,32 @@ mkMsgHandler botConfig eventChan name =
   flip (`foldM` Nothing) [ Logger.mkMsgHandler
                          , SongSearch.mkMsgHandler
                          , Auth.mkMsgHandler
-                         , NickTracker.mkMsgHandler ]
+                         , NickTracker.mkMsgHandler ] $ \handlers handler ->
-    $ \acc h -> case acc of
+    case handlers of
-                  Just _  -> return acc
+      Just _  -> return handlers
-                  Nothing -> h botConfig eventChan name
+      Nothing -> handler botConfig eventChan name
 
 pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
-pingPong state PingMsg { .. } = do
+pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
   io $ atomicWriteIORef state msgTime
   return . Just $ PongCmd msg
-pingPong state PongMsg { .. } = do
+pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
   io $ atomicWriteIORef state msgTime
   return Nothing
-pingPong state IdleMsg { .. } | even (convert msgTime :: Int) = do
+pingPong state Message { msgDetails = IdleMsg { .. }, .. }
-  BotConfig { .. } <- ask
+  | even (convert msgTime :: Int) = do
-  let limit = fromIntegral $ botTimeout `div` 2
+    BotConfig { .. } <- ask
-  io $ do
+    let limit = fromIntegral $ botTimeout `div` 2
-    lastComm <- readIORef state
+    io $ do
-    if addUTCTime limit lastComm < msgTime
+      lastComm <- readIORef state
-      then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
+      if addUTCTime limit lastComm < msgTime
-      else return Nothing
+        then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
+        else return Nothing
 
 pingPong _ _ = return Nothing
 
 greeter ::  MonadMsgHandler m => Message -> m (Maybe Command)
-greeter ChannelMsg { .. } =
+greeter Message { msgDetails = ChannelMsg { .. }, .. } =
   return . map (ChannelMsgReply . (++ userNick user) . (++ " ")) . find (== clean msg) $ greetings
   where
     greetings = [ "hi", "hello", "hey", "sup", "bye"
@@ -67,7 +68,7 @@ greeter ChannelMsg { .. } =
 greeter _ = return Nothing
 
 welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
-welcomer JoinMsg { .. } = do
+welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
   BotConfig { .. } <- ask
   if userNick user /= botNick
     then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
@@ -76,7 +77,7 @@ welcomer JoinMsg { .. } = do
 welcomer _ = return Nothing
 
 help :: MonadMsgHandler m => Message -> m (Maybe Command)
-help ChannelMsg { .. }
+help Message { msgDetails = ChannelMsg { .. }, .. }
   | "!help" == clean msg = do
       BotConfig { .. } <- ask
       let commands = concatMap mapKeys . mapValues $ msgHandlerInfo

Network/IRC/Handlers/Auth.hs

@@ -5,7 +5,7 @@
 
 module Network.IRC.Handlers.Auth (mkMsgHandler) where
 
-import qualified Data.UUID as U
+import qualified Data.UUID    as U
 import qualified Data.UUID.V4 as U
 
 import ClassyPrelude
@@ -46,7 +46,7 @@ issueToken acid user = do
 -- handler
 
 authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m (Maybe Command)
-authMessage state PrivMsg { .. }
+authMessage state Message { msgDetails = PrivMsg { .. }, .. }
   | "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . io $
       readIORef state >>= flip issueToken (userNick user)
 authMessage _ _ = return Nothing
@@ -70,7 +70,7 @@ authEvent state event = case fromEvent event of
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
 mkMsgHandler BotConfig { .. } _ "auth" = do
-  state <- io (openLocalState emptyAuth >>= newIORef)
+  state <- io $ openLocalState emptyAuth >>= newIORef
   return . Just $ newMsgHandler { onMessage = authMessage state
                                 , onEvent   = authEvent state
                                 , onStop    = stopAuth state

Network/IRC/Handlers/Auth/Types.hs

@@ -5,12 +5,12 @@
 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)
 
-type Token = Text
+type Token   = Text
 newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
 
 emptyAuth :: Auth

Network/IRC/Handlers/MessageLogger.hs

@@ -2,8 +2,8 @@
 
 module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where
 
-import qualified Data.Configurator as C
+import qualified Data.Configurator       as C
-import qualified Data.Text.Format as TF
+import qualified Data.Text.Format        as TF
 import qualified Data.Text.Format.Params as TF
 
 import ClassyPrelude hiding      ((</>), (<.>), FilePath, log)
@@ -73,7 +73,7 @@ withLogFile action state = do
   return Nothing
 
 messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
-messageLogger message = case message of
+messageLogger Message { .. } = case msgDetails of
   ChannelMsg { .. } -> log "<{}> {}"                  [userNick user, msg]
   ActionMsg { .. }  -> log "<{}> {} {}"               [userNick user, userNick user, msg]
   KickMsg { .. }    -> log "** {} KICKED {} :{}"      [userNick user, kickedNick, msg]
@@ -85,6 +85,6 @@ messageLogger message = case message of
   _                 -> const $ return Nothing
   where
     log format args = withLogFile $ \logFile ->
-      TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)
+      TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args)
 
     fmtTime = pack . formatTime defaultTimeLocale "%F %T"

Network/IRC/Handlers/NickTracker.hs

@@ -5,8 +5,8 @@
 
 module Network.IRC.Handlers.NickTracker (mkMsgHandler) where
 
-import qualified Data.IxSet as IS
+import qualified Data.IxSet   as IS
-import qualified Data.UUID as U
+import qualified Data.UUID    as U
 import qualified Data.UUID.V4 as U
 
 import ClassyPrelude
@@ -40,7 +40,7 @@ saveNickTrack nt = do
 $(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
 
 nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message ->  m (Maybe Command)
-nickTrackerMsg state message = case message of
+nickTrackerMsg state Message { .. } = case msgDetails of
   ChannelMsg { .. } -> updateNickTrack state user msg msgTime        >> handleCommands msg
   ActionMsg { .. }  -> updateNickTrack state user msg msgTime        >> return Nothing
   JoinMsg { .. }    -> updateNickTrack state user "" msgTime         >> return Nothing
@@ -66,9 +66,7 @@ updateNickTrack state user message msgTime = io $ do
   (message', lastMessageOn', cn) <- case (message, mnt) of
     ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
     (_, Just (NickTrack { .. }))  -> return (message, msgTime, canonicalNick)
-    _                             -> do
+    _                             -> newCanonicalNick >>= \cn -> return (message, msgTime, cn)
-     cn <- newCanonicalNick
-     return (message, msgTime, cn)
 
   update acid . SaveNickTrack $
     NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
@@ -138,7 +136,7 @@ stopNickTracker state = io $ do
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
 mkMsgHandler BotConfig { .. } _ "nicktracker" = do
-  state <- io (openLocalState emptyNickTracking >>= newIORef)
+  state <- io $ openLocalState emptyNickTracking >>= newIORef
   return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
                                 , onStop    = stopNickTracker state
                                 , onHelp    = return helpMsgs }

Network/IRC/Handlers/NickTracker/Types.hs

@@ -4,13 +4,13 @@
 module Network.IRC.Handlers.NickTracker.Types where
 
 import ClassyPrelude
-import Data.Data (Data)
+import Data.Data     (Data)
-import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
+import Data.IxSet    (IxSet, Indexable (..), ixSet, ixFun)
-import Data.SafeCopy             (base, deriveSafeCopy)
+import Data.SafeCopy (base, deriveSafeCopy)
 
-newtype Nick = Nick Text deriving (Eq, Ord, Show, Data, Typeable)
+newtype Nick          = Nick Text          deriving (Eq, Ord, Show, Data, Typeable)
 newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
-newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
+newtype LastSeenOn    = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
 
 data NickTrack = NickTrack {
   nick          :: !Nick,
@@ -25,14 +25,13 @@ instance Indexable NickTrack where
                 , ixFun $ (: []) . canonicalNick
                 , ixFun $ (: []) . lastSeenOn ]
 
+newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
+                       deriving (Eq, Ord, Show, Data, Typeable)
+
 $(deriveSafeCopy 0 'base ''Nick)
 $(deriveSafeCopy 0 'base ''CanonicalNick)
 $(deriveSafeCopy 0 'base ''LastSeenOn)
 $(deriveSafeCopy 0 'base ''NickTrack)
-
-newtype NickTracking = NickTracking { nickTracking :: IxSet NickTrack }
-                       deriving (Eq, Ord, Show, Data, Typeable)
-
 $(deriveSafeCopy 0 'base ''NickTracking)
 
 emptyNickTracking :: NickTracking

Network/IRC/Handlers/SongSearch.hs

@@ -42,7 +42,7 @@ instance FromJSON Song where
     parseJSON _                   = mempty
 
 songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
-songSearch ChannelMsg { .. }
+songSearch Message { msgDetails = ChannelMsg { .. }, .. }
   | "!m " `isPrefixOf` msg = do
       BotConfig { .. } <- ask
       liftIO $ do

Network/IRC/Protocol.hs

@@ -1,4 +1,4 @@
-module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
+module Network.IRC.Protocol (MessageParser, msgFromLine, lineFromCommand) where
 
 import ClassyPrelude
 import Data.List ((!!))
@@ -6,25 +6,27 @@ import Data.Text (split, strip)
 
 import Network.IRC.Types
 
-msgFromLine :: BotConfig -> UTCTime -> Text -> Message
+type MessageParser = BotConfig -> UTCTime -> Text -> Message
+
+msgFromLine :: MessageParser
 msgFromLine (BotConfig { .. }) time line
-  | "PING :" `isPrefixOf` line = PingMsg time (drop 6 line) line
+  | "PING :" `isPrefixOf` line = Message time line $ PingMsg (drop 6 line)
   | otherwise = case command of
-      "PONG"    -> PongMsg time message line
+      "PONG"    -> Message time line $ PongMsg message
-      "JOIN"    -> JoinMsg time user line
+      "JOIN"    -> Message time line $ JoinMsg user
-      "QUIT"    -> QuitMsg time user quitMessage line
+      "QUIT"    -> Message time line $ QuitMsg user quitMessage
-      "PART"    -> PartMsg time user message line
+      "PART"    -> Message time line $ PartMsg user message
-      "KICK"    -> KickMsg time user kicked kickReason line
+      "KICK"    -> Message time line $ KickMsg user kicked kickReason
       "MODE"    -> if source == botNick
-                     then ModeMsg time Self target message [] line
+                     then Message time line $ ModeMsg Self target message []
-                     else ModeMsg time user target mode modeArgs line
+                     else Message time line $ ModeMsg user target mode modeArgs
-      "NICK"    -> NickMsg time user (drop 1 target) line
+      "NICK"    -> Message time line $ NickMsg user (drop 1 target)
-      "353"     -> NamesMsg time namesNicks
+      "353"     -> Message time line $ NamesMsg namesNicks
-      "433"     -> NickInUseMsg time line
+      "433"     -> Message time line NickInUseMsg
-      "PRIVMSG" | target /= channel -> PrivMsg time user message line
+      "PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message
-                | isActionMsg       -> ActionMsg time user (initDef . drop 8 $ message) line
+                | isActionMsg       -> Message time line $ ActionMsg user (initDef . drop 8 $ message)
-                | otherwise         -> ChannelMsg time user message line
+                | otherwise         -> Message time line $ ChannelMsg user message
-      _         -> OtherMsg time source command target message line
+      _         -> Message time line $ OtherMsg source command target message
   where
     isSpc           = (== ' ')
     isNotSpc        = not . isSpc
@@ -40,8 +42,7 @@ msgFromLine (BotConfig { .. }) time line
     kicked          = splits !! 3
     kickReason      = drop 1 . unwords . drop 4 $ splits
 
-    nickPrefixes :: String
+    nickPrefixes    = "~&@%+" :: String
-    nickPrefixes    = "~&@%+"
     namesNicks      = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
     stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack
 

Network/IRC/Types.hs

@@ -10,6 +10,7 @@ module Network.IRC.Types
   , MsgHandlerName
   , User (..)
   , Message (..)
+  , MessageDetails (..)
   , Command (..)
   , Event (..)
   , SomeEvent
@@ -45,25 +46,25 @@ type MsgHandlerName = Text
 data User = Self | User { userNick :: !Nick, userServer :: !Text }
             deriving (Show, Eq)
 
-data Message =
+data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails}
-    IdleMsg      { msgTime  :: !UTCTime}
+               deriving (Show, Eq)
-  | PingMsg      { msgTime  :: !UTCTime, msg     :: !Text, msgLine     :: !Text }
+
-  | PongMsg      { msgTime  :: !UTCTime, msg     :: !Text, msgLine     :: !Text }
+data MessageDetails =
-  | ChannelMsg   { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
+    IdleMsg
-  | PrivMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
+  | NickInUseMsg
-  | ActionMsg    { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
+  | PingMsg      { msg       :: !Text }
-  | JoinMsg      { msgTime  :: !UTCTime, user    :: !User, msgLine     :: !Text }
+  | PongMsg      { msg       :: !Text }
-  | QuitMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
+  | NamesMsg     { nicks     :: ![Nick] }
-  | PartMsg      { msgTime  :: !UTCTime, user    :: !User, msg         :: !Text, msgLine :: !Text }
+  | ChannelMsg   { user      :: !User, msg        :: !Text }
-  | NickMsg      { msgTime  :: !UTCTime, user    :: !User, newNick     :: !Nick, msgLine :: !Text }
+  | PrivMsg      { user      :: !User, msg        :: !Text }
-  | NickInUseMsg { msgTime  :: !UTCTime, msgLine :: !Text }
+  | ActionMsg    { user      :: !User, msg        :: !Text }
-  | KickMsg      { msgTime  :: !UTCTime, user    :: !User, kickedNick  :: !Nick, msg     :: !Text
+  | JoinMsg      { user      :: !User }
-                 , msgLine  :: !Text }
+  | QuitMsg      { user      :: !User, msg        :: !Text }
-  | ModeMsg      { msgTime  :: !UTCTime, user    :: !User, target      :: !Text, mode    :: !Text
+  | PartMsg      { user      :: !User, msg        :: !Text }
-                 , modeArgs :: ![Text], msgLine  :: !Text }
+  | NickMsg      { user      :: !User, newNick    :: !Nick }
-  | NamesMsg     { msgTime  :: !UTCTime, nicks   :: ![Nick] }
+  | KickMsg      { user      :: !User, kickedNick :: !Nick, msg       :: !Text }
-  | OtherMsg     { msgTime  :: !UTCTime, source  :: !Text, command     :: !Text, target  :: !Text
+  | ModeMsg      { user      :: !User, msgTarget  :: !Text, mode      :: !Text , modeArgs :: ![Text] }
-                 , msg      :: !Text,   msgLine  :: !Text }
+  | OtherMsg     { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg      :: !Text }
   deriving (Show, Eq)
 
 data Command =
@@ -113,11 +114,11 @@ data BotConfig = BotConfig { server         :: !Text
                            , config         :: !Config }
 
 instance Show BotConfig where
-  show BotConfig { .. } = "server = "   ++ show server          ++ "\n" ++
+  show BotConfig { .. } = "server = "   ++ show server     ++ "\n" ++
-                          "port = "     ++ show port            ++ "\n" ++
+                          "port = "     ++ show port       ++ "\n" ++
-                          "channel = "  ++ show channel         ++ "\n" ++
+                          "channel = "  ++ show channel    ++ "\n" ++
-                          "nick = "     ++ show botNick         ++ "\n" ++
+                          "nick = "     ++ show botNick    ++ "\n" ++
-                          "timeout = "  ++ show botTimeout      ++ "\n" ++
+                          "timeout = "  ++ show botTimeout ++ "\n" ++
                           "handlers = " ++ show (mapKeys msgHandlerInfo)
 
 data Bot = Bot { botConfig   :: !BotConfig
@@ -148,11 +149,11 @@ runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC
 -- Message handlers
 
 newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
-                     deriving ( Functor
+                        deriving ( Functor
-                              , Applicative
+                                 , Applicative
-                              , Monad
+                                 , Monad
-                              , MonadIO
+                                 , MonadIO
-                              , MonadReader BotConfig )
+                                 , MonadReader BotConfig )
 
 class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m where
   msgHandler :: MsgHandlerT a -> m a

hask-irc.cabal

@@ -50,7 +50,7 @@ cabal-version:       >=1.10
 
 library
   default-extensions:  NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
-                       BangPatterns, TupleSections
+                       BangPatterns, TupleSections, NamedFieldPuns
 
   build-depends:       base              >=4.5     && <4.8,
                        text              >=0.11    && <0.12,
@@ -93,7 +93,7 @@ executable hask-irc
 
   -- LANGUAGE extensions used by modules in this package.
   default-extensions:  NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
-                       BangPatterns, TupleSections
+                       BangPatterns, TupleSections, NamedFieldPuns
 
   -- Other library packages from which modules are imported.
   build-depends:       base              >=4.5     && <4.8,