2014-05-25 18:13:52 +05:30
|
|
|
module Network.IRC.Handlers.Core (mkMsgHandler) where
|
2014-05-04 02:57:43 +05:30
|
|
|
|
2014-05-10 21:45:16 +05:30
|
|
|
import ClassyPrelude
|
2014-05-21 11:20:53 +05:30
|
|
|
import Control.Concurrent.Lifted (Chan)
|
|
|
|
import Control.Monad.Reader (ask)
|
|
|
|
import Data.Convertible (convert)
|
|
|
|
import Data.Time (addUTCTime)
|
2014-05-04 02:57:43 +05:30
|
|
|
|
|
|
|
import Network.IRC.Types
|
2014-05-22 20:59:02 +05:30
|
|
|
import Network.IRC.Util
|
2014-05-04 02:57:43 +05:30
|
|
|
|
2014-05-21 00:06:37 +05:30
|
|
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
|
|
|
mkMsgHandler _ _ "pingpong" = do
|
2014-05-20 00:05:06 +05:30
|
|
|
state <- getCurrentTime >>= newIORef
|
2014-05-21 00:06:37 +05:30
|
|
|
return . Just $ newMsgHandler { onMessage = pingPong state }
|
2014-05-22 20:59:02 +05:30
|
|
|
mkMsgHandler _ _ "help" =
|
2014-05-23 02:45:45 +05:30
|
|
|
return . Just $ newMsgHandler { onMessage = help,
|
|
|
|
onHelp = return $ singletonMap "!help" helpMsg }
|
2014-05-22 20:59:02 +05:30
|
|
|
where
|
|
|
|
helpMsg = "Get help. !help or !help <command>"
|
2014-05-25 18:13:52 +05:30
|
|
|
mkMsgHandler _ _ _ = return Nothing
|
2014-05-04 02:57:43 +05:30
|
|
|
|
2014-06-01 06:48:24 +05:30
|
|
|
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
|
2014-05-25 01:09:31 +05:30
|
|
|
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
|
2014-05-23 12:21:38 +05:30
|
|
|
io $ atomicWriteIORef state msgTime
|
2014-06-01 06:48:24 +05:30
|
|
|
return [PongCmd msg]
|
2014-05-25 01:09:31 +05:30
|
|
|
pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
|
2014-05-23 12:21:38 +05:30
|
|
|
io $ atomicWriteIORef state msgTime
|
2014-06-01 06:48:24 +05:30
|
|
|
return []
|
2014-05-25 01:09:31 +05:30
|
|
|
pingPong state Message { msgDetails = IdleMsg { .. }, .. }
|
|
|
|
| even (convert msgTime :: Int) = do
|
|
|
|
BotConfig { .. } <- ask
|
|
|
|
let limit = fromIntegral $ botTimeout `div` 2
|
|
|
|
io $ do
|
|
|
|
lastComm <- readIORef state
|
|
|
|
if addUTCTime limit lastComm < msgTime
|
2014-06-01 06:48:24 +05:30
|
|
|
then return [PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime]
|
|
|
|
else return []
|
2014-05-23 04:56:26 +05:30
|
|
|
|
2014-06-01 06:48:24 +05:30
|
|
|
pingPong _ _ = return []
|
2014-05-11 14:01:09 +05:30
|
|
|
|
2014-06-01 06:48:24 +05:30
|
|
|
help :: MonadMsgHandler m => Message -> m [Command]
|
2014-05-25 01:09:31 +05:30
|
|
|
help Message { msgDetails = ChannelMsg { .. }, .. }
|
2014-05-22 20:59:02 +05:30
|
|
|
| "!help" == clean msg = do
|
|
|
|
BotConfig { .. } <- ask
|
|
|
|
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
|
2014-06-01 06:48:24 +05:30
|
|
|
return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
|
2014-05-22 20:59:02 +05:30
|
|
|
| "!help" `isPrefixOf` msg = do
|
|
|
|
BotConfig { .. } <- ask
|
2014-05-23 04:38:52 +05:30
|
|
|
let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
|
2014-05-22 20:59:02 +05:30
|
|
|
let mHelp = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
|
2014-06-01 06:48:24 +05:30
|
|
|
return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
|
2014-05-22 20:59:02 +05:30
|
|
|
|
2014-06-01 06:48:24 +05:30
|
|
|
help _ = return []
|