abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added help handler

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-05-22 20:59:02 +05:30
parent 5cef08de36
commit 96a61f3b32
10 changed files with 121 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Main.hs
View File

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

8
Network/IRC/Bot.hs
View File

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

39
Network/IRC/Client.hs
View File

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

30
Network/IRC/Handlers.hs
View File

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

37
Network/IRC/Handlers/Auth.hs
View File

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

5
Network/IRC/Handlers/Auth/Types.hs
View File

@ -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 ++ "]"

6
Network/IRC/Handlers/MessageLogger.hs
View File

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

6
Network/IRC/Handlers/SongSearch.hs
View File

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

31
Network/IRC/Types.hs
View File

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

6
Network/IRC/Util.hs
View File

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