diff --git a/Main.hs b/Main.hs index c61b899..09292ab 100644 --- a/Main.hs +++ b/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 <$> - CF.require cfg "server" <*> - CF.require cfg "port" <*> - CF.require cfg "channel" <*> - CF.require cfg "nick" <*> - CF.require cfg "timeout" <*> - CF.require cfg "msghandlers" <*> - pure cfg + eBotConfig <- try $ do + handlers :: [Text] <- CF.require cfg "msghandlers" + let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers + BotConfig <$> + CF.require cfg "server" <*> + CF.require cfg "port" <*> + CF.require cfg "channel" <*> + 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 diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs index e0dc9f2..4613072 100644 --- a/Network/IRC/Bot.hs +++ b/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 - Nothing -> return () - Just cmd -> sendCommand commandChan cmd + maybe (return ()) (sendCommand commandChan) mCmd 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 diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 8ba3e2e..c6d2a9c 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -29,13 +29,15 @@ connect botConfig@BotConfig { .. } = do hSetBuffering socket LineBuffering debugM "Connected" - lineChan <- newChannel - commandChan <- newChannel - eventChan <- newChannel - mvBotStatus <- newMVar Connected - msgHandlers <- loadMsgHandlers (fst eventChan) - - return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan) + lineChan <- newChannel + commandChan <- newChannel + eventChan <- newChannel + mvBotStatus <- newMVar Connected + msgHandlers <- loadMsgHandlers (fst eventChan) + msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m) + mempty (mapToList msgHandlers) + let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'} + return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan) 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 - debugM . unpack $ "Loading msg handler: " ++ msgHandlerName - mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName - case mMsgHandler of - Nothing -> do - debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName - return hMap - Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap + loadMsgHandlers eventChan = + flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do + debugM . unpack $ "Loading msg handler: " ++ msgHandlerName + mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName + case mMsgHandler of + Nothing -> do + debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName + 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 diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index 2d23179..2e572c0 100644 --- a/Network/IRC/Handlers.hs +++ b/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.SongSearch as SS -import qualified Network.IRC.Handlers.Auth as A +import qualified Network.IRC.Handlers.MessageLogger as Logger +import qualified Network.IRC.Handlers.SongSearch as SongSearch +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 " 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 + diff --git a/Network/IRC/Handlers/Auth.hs b/Network/IRC/Handlers/Auth.hs index f070b0e..acc0024 100644 --- a/Network/IRC/Handlers/Auth.hs +++ b/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.Advanced (query', update') +import Data.Acid (AcidState, Query, Update, makeAcidic, 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 -emptyAuth = Auth mempty +-- database $(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 - acid <- readIORef state - token <- issueToken acid (userNick user) - return . Just $ PrivMsgReply user token + | "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . liftIO $ + readIORef state >>= flip issueToken (userNick user) 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 } -mkMsgHandler _ _ _ = return Nothing + , onStop = stopAuth state + , onHelp = return $ singletonMap "token" helpMsg } + where + helpMsg = "Send a PM to get a new auth token. /msg " ++ botNick ++ " token" +mkMsgHandler _ _ _ = return Nothing diff --git a/Network/IRC/Handlers/Auth/Types.hs b/Network/IRC/Handlers/Auth/Types.hs index 9a0c8df..daa3ecd 100644 --- a/Network/IRC/Handlers/Auth/Types.hs +++ b/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 ++ "]" diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 00b940d..5971c72 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/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 - mHandle <- readIORef state - case mHandle of - Nothing -> return () - Just (logFileHandle, _) -> hClose logFileHandle +exitMessageLogger state = liftIO $ readIORef state >>= maybe (return ()) (hClose . fst) withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command) withLogFile action state = do diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index e31be0c..5d6755a 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/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 or !m - " mkMsgHandler _ _ _ = return Nothing data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 42a4a6f..996113b 100644 --- a/Network/IRC/Types.hs +++ b/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 - , port :: !Int - , channel :: !Text - , botNick :: !Text - , botTimeout :: !Int - , msgHandlerNames :: ![MsgHandlerName] - , config :: !Config } +data BotConfig = BotConfig { server :: !Text + , port :: !Int + , channel :: !Text + , botNick :: !Text + , botTimeout :: !Int + , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) + , 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 } diff --git a/Network/IRC/Util.hs b/Network/IRC/Util.hs index 0298a4e..ad83942 100644 --- a/Network/IRC/Util.hs +++ b/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