Added help handler

Main.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverlappingInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Main (main) where
 
@@ -56,14 +57,17 @@ loadBotConfig configFile = do
   case eCfg of
     Left (ParseError _ _) -> error "Error while loading config"
     Right cfg             -> do
-      eBotConfig <- try $ BotConfig                    <$>
+      eBotConfig <- try $ do
-                          CF.require cfg "server"      <*>
+        handlers :: [Text] <- CF.require cfg "msghandlers"
-                          CF.require cfg "port"        <*>
+        let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
-                          CF.require cfg "channel"     <*>
+        BotConfig                  <$>
-                          CF.require cfg "nick"        <*>
+          CF.require cfg "server"  <*>
-                          CF.require cfg "timeout"     <*>
+          CF.require cfg "port"    <*>
-                          CF.require cfg "msghandlers" <*>
+          CF.require cfg "channel" <*>
-                          pure cfg
+          CF.require cfg "nick"    <*>
+          CF.require cfg "timeout" <*>
+          pure handlerInfo         <*>
+          pure cfg
 
       case eBotConfig of
         Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k

Network/IRC/Bot.hs

@@ -128,13 +128,11 @@ messageProcessLoop lineChan commandChan !idleFor = do
 
   where
     dispatchHandlers Bot { .. } message =
-      forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
+      forM_ (mapValues msgHandlers) $ \msgHandler -> fork $
         handle (\(e :: SomeException) ->
                   errorM $ "Exception while processing message: " ++ show e) $ do
           mCmd <- handleMessage msgHandler botConfig message
-          case mCmd of
+          maybe (return ()) (sendCommand commandChan) mCmd
-            Nothing  -> return ()
-            Just cmd -> sendCommand commandChan cmd
 
 eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
 eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
@@ -143,7 +141,7 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
     Just (QuitEvent, _) -> latchIt latch
     _                   -> do
       debugM $ "Event: " ++ show event
-      forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
+      forM_ (mapValues msgHandlers) $ \msgHandler -> fork $
         handle (\(ex :: SomeException) ->
                   errorM $ "Exception while processing event: " ++ show ex) $ do
           resp <- handleEvent msgHandler botConfig event

Network/IRC/Client.hs

@@ -29,13 +29,15 @@ connect botConfig@BotConfig { .. } = do
   hSetBuffering socket LineBuffering
   debugM "Connected"
 
-  lineChan    <- newChannel
+  lineChan        <- newChannel
-  commandChan <- newChannel
+  commandChan     <- newChannel
-  eventChan   <- newChannel
+  eventChan       <- newChannel
-  mvBotStatus <- newMVar Connected
+  mvBotStatus     <- newMVar Connected
-  msgHandlers <- loadMsgHandlers (fst eventChan)
+  msgHandlers     <- loadMsgHandlers (fst eventChan)
-
+  msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
-  return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
+                       mempty (mapToList msgHandlers)
+  let botConfig'  = botConfig { msgHandlerInfo = msgHandlerInfo'}
+  return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
   where
     connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
                            `catch` (\(e :: SomeException) -> do
@@ -45,14 +47,15 @@ connect botConfig@BotConfig { .. } = do
 
     newChannel = (,) <$> newChan <*> newEmptyMVar
 
-    loadMsgHandlers eventChan = flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
+    loadMsgHandlers eventChan =
-      debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
+      flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
-      mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
+        debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
-      case mMsgHandler of
+        mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
-        Nothing         -> do
+        case mMsgHandler of
-          debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
+          Nothing         -> do
-          return hMap
+            debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
-        Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
+            return hMap
+          Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
 
 disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) -> IO ()
 disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
@@ -85,7 +88,11 @@ runBot botConfig' = withSocketsDo $ do
     NickNotAvailable -> return ()
     _                -> error "Unsupported status"
   where
-    botConfig = botConfig' { msgHandlerNames = hashNub $ msgHandlerNames botConfig' ++ coreMsgHandlerNames }
+    botConfig = botConfig' {
+      msgHandlerInfo =
+        foldl' (\m name -> insertMap name mempty m) mempty
+          (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames)
+    }
 
     handleErrors :: SomeException -> IO BotStatus
     handleErrors e = case fromException e of

Network/IRC/Handlers.hs

@@ -5,9 +5,9 @@
 
 module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
 
-import qualified Network.IRC.Handlers.MessageLogger as L
+import qualified Network.IRC.Handlers.MessageLogger as Logger
-import qualified Network.IRC.Handlers.SongSearch as SS
+import qualified Network.IRC.Handlers.SongSearch    as SongSearch
-import qualified Network.IRC.Handlers.Auth as A
+import qualified Network.IRC.Handlers.Auth          as Auth
 
 import ClassyPrelude
 import Control.Concurrent.Lifted  (Chan)
@@ -17,12 +17,13 @@ import Data.Text                  (strip)
 import Data.Time                  (addUTCTime)
 
 import Network.IRC.Types
+import Network.IRC.Util
 
 clean :: Text -> Text
 clean = toLower . strip
 
 coreMsgHandlerNames :: [Text]
-coreMsgHandlerNames = ["pingpong", "messagelogger"]
+coreMsgHandlerNames = ["pingpong", "messagelogger", "help"]
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
 mkMsgHandler _ _ "greeter"  = return . Just $ newMsgHandler { onMessage = greeter }
@@ -30,9 +31,13 @@ mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcom
 mkMsgHandler _ _ "pingpong" = do
   state <- getCurrentTime >>= newIORef
   return . Just $ newMsgHandler { onMessage = pingPong state }
+mkMsgHandler _ _ "help"     =
+    return . Just $ newMsgHandler { onMessage = help, onHelp = return $ singletonMap "!help" helpMsg}
+  where
+    helpMsg = "Get help. !help or !help <command>"
 
 mkMsgHandler botConfig eventChan name =
-  flip (`foldM` Nothing) [L.mkMsgHandler, SS.mkMsgHandler, A.mkMsgHandler] $ \acc h ->
+  flip (`foldM` Nothing) [Logger.mkMsgHandler, SongSearch.mkMsgHandler, Auth.mkMsgHandler] $ \acc h ->
     case acc of
       Just _  -> return acc
       Nothing -> h botConfig eventChan name
@@ -72,3 +77,18 @@ welcomer JoinMsg { .. } = do
     else return Nothing
 
 welcomer _ = return Nothing
+
+help :: MonadMsgHandler m => Message -> m (Maybe Command)
+help ChannelMsg { .. }
+  | "!help" == clean msg = do
+      BotConfig { .. } <- ask
+      let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
+      return . Just . ChannelMsgReply $ "I know these commands: " ++ unwords commands
+  | "!help" `isPrefixOf` msg = do
+      BotConfig { .. } <- ask
+      let command = clean . unwords . drop 1 . words $ msg
+      let mHelp   = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
+      return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
+
+help _ = return Nothing
+

Network/IRC/Handlers/Auth.hs

@@ -15,16 +15,15 @@ import ClassyPrelude
 import Control.Concurrent.Lifted (Chan)
 import Control.Monad.Reader      (asks)
 import Control.Monad.State       (get, put)
-import Data.Acid                 (AcidState, Query, Update, makeAcidic, openLocalState)
+import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
-import Data.Acid.Advanced        (query', update')
+                                  openLocalState, createArchive)
 import Data.Acid.Local           (createCheckpointAndClose)
 import Data.SafeCopy             (base, deriveSafeCopy)
 
 import Network.IRC.Handlers.Auth.Types
 import Network.IRC.Types
 
-emptyAuth :: Auth
+-- database
-emptyAuth = Auth mempty
 
 $(deriveSafeCopy 0 'base ''Auth)
 
@@ -41,40 +40,46 @@ $(makeAcidic ''Auth ['getToken, 'saveToken, 'deleteToken])
 
 issueToken :: AcidState Auth -> Nick -> IO Token
 issueToken acid user = do
-  mt <- query' acid (GetToken user)
+  mt <- query acid (GetToken user)
   case mt of
     Just t -> return t
     Nothing -> do
       token <- map (pack . U.toString) U.nextRandom
-      update' acid (SaveToken user token)
+      update acid (SaveToken user token)
       return token
 
+-- handler
+
 authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m (Maybe Command)
 authMessage state PrivMsg { .. }
-  | "token" `isPrefixOf` msg = liftIO $ do
+  | "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . liftIO $
-      acid  <- readIORef state
+      readIORef state >>= flip issueToken (userNick user)
-      token <- issueToken acid (userNick user)
-      return . Just $ PrivMsgReply user token
 authMessage _ _ = return Nothing
 
 stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
-stopAuth state = liftIO $ readIORef state >>= createCheckpointAndClose
+stopAuth state = liftIO $ do
+  acid <- readIORef state
+  createArchive acid
+  createCheckpointAndClose acid
 
 authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> SomeEvent -> m EventResponse
 authEvent state event = case fromEvent event of
   Just (AuthEvent user token reply, _) -> liftIO $ do
     acid <- readIORef state
-    mt <- query' acid (GetToken user)
+    mt   <- query acid (GetToken user)
     case mt of
       Just t  -> putMVar reply (t == token)
       Nothing -> putMVar reply False
     return RespNothing
-  _                                 -> return RespNothing
+  _                                    -> return RespNothing
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
-mkMsgHandler _ _ "auth" = do
+mkMsgHandler BotConfig { .. } _ "auth" = do
   state <- liftIO (openLocalState emptyAuth >>= newIORef)
   return . Just $ newMsgHandler { onMessage = authMessage state
                                 , onEvent   = authEvent state
-                                , onStop    = stopAuth state }
+                                , onStop    = stopAuth state
-mkMsgHandler _ _ _                       = return Nothing
+                                , onHelp    = return $ singletonMap "token" helpMsg }
+  where
+    helpMsg = "Send a PM to get a new auth token. /msg " ++ botNick ++ " token"
+mkMsgHandler _ _ _                     = return Nothing

Network/IRC/Handlers/Auth/Types.hs

@@ -11,7 +11,12 @@ import Network.IRC.Types hiding (user)
 type Token = Text
 newtype Auth = Auth { auth :: Map Nick Token } deriving (Eq, Show, Data, Typeable)
 
+emptyAuth :: Auth
+emptyAuth = Auth mempty
+
 data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
+
 instance Event AuthEvent
+
 instance Show AuthEvent where
   show (AuthEvent user token _) = "AuthEvent[" ++ unpack user ++ ", " ++ unpack token ++ "]"

Network/IRC/Handlers/MessageLogger.hs

@@ -51,11 +51,7 @@ initMessageLogger botConfig state = do
   atomicWriteIORef state $ Just (logFileHandle, utctDay time)
 
 exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
-exitMessageLogger state = liftIO $ do
+exitMessageLogger state = liftIO $ readIORef state >>= maybe (return ()) (hClose . fst)
-  mHandle <- readIORef state
-  case mHandle of
-    Nothing                 -> return ()
-    Just (logFileHandle, _) -> hClose logFileHandle
 
 withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
 withLogFile action state = do

Network/IRC/Handlers/SongSearch.hs

@@ -26,7 +26,11 @@ import Network.IRC.Types
 $(deriveLoggers "HSL" [HSL.ERROR])
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
-mkMsgHandler _ _ "songsearch" = return . Just $ newMsgHandler { onMessage = songSearch }
+mkMsgHandler _ _ "songsearch" =
+  return . Just $ newMsgHandler { onMessage = songSearch,
+                                  onHelp    = return $ singletonMap "!m" helpMsg }
+  where
+    helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
 mkMsgHandler _ _ _            = return Nothing
 
 data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }

Network/IRC/Types.hs

@@ -28,7 +28,8 @@ module Network.IRC.Types
   , newMsgHandler
   , handleMessage
   , handleEvent
-  , stopMsgHandler )
+  , stopMsgHandler
+  , getHelp )
 where
 
 import ClassyPrelude
@@ -37,6 +38,8 @@ import Control.Monad.State     (StateT, MonadState, execStateT)
 import Data.Configurator.Types (Config)
 import Data.Typeable           (cast)
 
+import Network.IRC.Util
+
 -- IRC related
 
 type Nick           = Text
@@ -104,13 +107,13 @@ data EventResponse =  RespNothing
 
 -- Bot
 
-data BotConfig = BotConfig { server          :: !Text
+data BotConfig = BotConfig { server         :: !Text
-                           , port            :: !Int
+                           , port           :: !Int
-                           , channel         :: !Text
+                           , channel        :: !Text
-                           , botNick         :: !Text
+                           , botNick        :: !Text
-                           , botTimeout      :: !Int
+                           , botTimeout     :: !Int
-                           , msgHandlerNames :: ![MsgHandlerName]
+                           , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
-                           , config          :: !Config }
+                           , config         :: !Config }
 
 instance Show BotConfig where
   show BotConfig { .. } = "server = "   ++ show server          ++ "\n" ++
@@ -118,7 +121,7 @@ instance Show BotConfig where
                           "channel = "  ++ show channel         ++ "\n" ++
                           "nick = "     ++ show botNick         ++ "\n" ++
                           "timeout = "  ++ show botTimeout      ++ "\n" ++
-                          "handlers = " ++ show msgHandlerNames
+                          "handlers = " ++ show (mapKeys msgHandlerInfo)
 
 data Bot = Bot { botConfig   :: !BotConfig
                , socket      :: !Handle
@@ -172,15 +175,21 @@ handleEvent :: MsgHandler -> BotConfig -> SomeEvent -> IO EventResponse
 handleEvent MsgHandler { .. } botConfig =
   flip runReaderT botConfig . _runMsgHandler . onEvent
 
+getHelp :: MsgHandler -> BotConfig -> IO (Map Text Text)
+getHelp MsgHandler { .. } botConfig =
+  flip runReaderT botConfig . _runMsgHandler $ onHelp
+
 data MsgHandler = MsgHandler {
   onMessage :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)),
   onStop    :: !(forall m . MonadMsgHandler m => m ()),
-  onEvent   :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse)
+  onEvent   :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse),
+  onHelp    :: !(forall m . MonadMsgHandler m => m (Map Text Text))
 }
 
 newMsgHandler :: MsgHandler
 newMsgHandler = MsgHandler {
   onMessage = const $ return Nothing,
   onStop    = return (),
-  onEvent   = const $ return RespNothing
+  onEvent   = const $ return RespNothing,
+  onHelp    = return mempty
 }

Network/IRC/Util.hs

@@ -22,3 +22,9 @@ awaitLatch :: Latch -> IO ()
 awaitLatch latch = void $ takeMVar latch
 
 type Channel a = (Chan a, Latch)
+
+mapKeys :: IsMap map => map -> [ContainerKey map]
+mapKeys   = map fst . mapToList
+
+mapValues :: IsMap map => map -> [MapValue map]
+mapValues = map snd . mapToList