Added tell command handler
parent
068b967e8e
commit
651244834e
|
@ -143,8 +143,8 @@ messageProcessLoop = messageProcessLoop' 0
|
||||||
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
|
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
|
||||||
handle (\(e :: SomeException) ->
|
handle (\(e :: SomeException) ->
|
||||||
errorM $ "Exception while processing message: " ++ show e) $ do
|
errorM $ "Exception while processing message: " ++ show e) $ do
|
||||||
mCmd <- handleMessage msgHandler botConfig message
|
cmds <- handleMessage msgHandler botConfig message
|
||||||
whenJust mCmd (sendCommand commandChan)
|
forM_ cmds (sendCommand commandChan)
|
||||||
|
|
||||||
eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
|
|
|
@ -172,7 +172,7 @@ class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => Mon
|
||||||
instance MonadMsgHandler MsgHandlerT where
|
instance MonadMsgHandler MsgHandlerT where
|
||||||
msgHandler = id
|
msgHandler = id
|
||||||
|
|
||||||
handleMessage :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
|
handleMessage :: MsgHandler -> BotConfig -> Message -> IO [Command]
|
||||||
handleMessage MsgHandler { .. } botConfig =
|
handleMessage MsgHandler { .. } botConfig =
|
||||||
flip runReaderT botConfig . _runMsgHandler . onMessage
|
flip runReaderT botConfig . _runMsgHandler . onMessage
|
||||||
|
|
||||||
|
@ -189,7 +189,7 @@ getHelp MsgHandler { .. } botConfig =
|
||||||
flip runReaderT botConfig . _runMsgHandler $ onHelp
|
flip runReaderT botConfig . _runMsgHandler $ onHelp
|
||||||
|
|
||||||
data MsgHandler = MsgHandler {
|
data MsgHandler = MsgHandler {
|
||||||
onMessage :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)),
|
onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Command]),
|
||||||
onStop :: !(forall m . MonadMsgHandler m => m ()),
|
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))
|
onHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text))
|
||||||
|
@ -197,7 +197,7 @@ data MsgHandler = MsgHandler {
|
||||||
|
|
||||||
newMsgHandler :: MsgHandler
|
newMsgHandler :: MsgHandler
|
||||||
newMsgHandler = MsgHandler {
|
newMsgHandler = MsgHandler {
|
||||||
onMessage = const $ return Nothing,
|
onMessage = const $ return [],
|
||||||
onStop = return (),
|
onStop = return (),
|
||||||
onEvent = const $ return RespNothing,
|
onEvent = const $ return RespNothing,
|
||||||
onHelp = return mempty
|
onHelp = return mempty
|
||||||
|
|
|
@ -57,10 +57,9 @@ relativeTime t1 t2 =
|
||||||
format range =
|
format range =
|
||||||
(if period > 0 then "in " else "")
|
(if period > 0 then "in " else "")
|
||||||
++ case range of
|
++ case range of
|
||||||
(0, _, _) -> "moments"
|
|
||||||
(_, str, 0) -> pack str
|
(_, str, 0) -> pack str
|
||||||
(_, str, base) -> TF.format (fromString str) $ TF.Only (abs $ round (period / base) :: Integer)
|
(_, str, base) -> TF.format (fromString str) $ TF.Only (abs $ round (period / base) :: Integer)
|
||||||
++ (if period < 0 then " ago" else "")
|
++ (if period <= 0 then " ago" else "")
|
||||||
|
|
||||||
period = t1 `diffUTCTime` t2
|
period = t1 `diffUTCTime` t2
|
||||||
|
|
||||||
|
|
|
@ -8,6 +8,7 @@ import qualified Network.IRC.Handlers.Greet as Greet
|
||||||
import qualified Network.IRC.Handlers.MessageLogger as Logger
|
import qualified Network.IRC.Handlers.MessageLogger as Logger
|
||||||
import qualified Network.IRC.Handlers.NickTracker as NickTracker
|
import qualified Network.IRC.Handlers.NickTracker as NickTracker
|
||||||
import qualified Network.IRC.Handlers.SongSearch as SongSearch
|
import qualified Network.IRC.Handlers.SongSearch as SongSearch
|
||||||
|
import qualified Network.IRC.Handlers.Tell as Tell
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Control.Concurrent.Lifted (Chan)
|
import Control.Concurrent.Lifted (Chan)
|
||||||
|
@ -32,4 +33,5 @@ mkMsgHandler botConfig eventChan name =
|
||||||
, Logger.mkMsgHandler
|
, Logger.mkMsgHandler
|
||||||
, NickTracker.mkMsgHandler
|
, NickTracker.mkMsgHandler
|
||||||
, SongSearch.mkMsgHandler
|
, SongSearch.mkMsgHandler
|
||||||
|
, Tell.mkMsgHandler
|
||||||
]
|
]
|
||||||
|
|
|
@ -43,11 +43,11 @@ issueToken acid user = do
|
||||||
|
|
||||||
-- handler
|
-- handler
|
||||||
|
|
||||||
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m (Maybe Command)
|
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m [Command]
|
||||||
authMessage state Message { msgDetails = PrivMsg { .. }, .. }
|
authMessage state Message { msgDetails = PrivMsg { .. }, .. }
|
||||||
| "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . io $
|
| "token" `isPrefixOf` msg = map (singleton . PrivMsgReply user) . io $
|
||||||
readIORef state >>= flip issueToken (userNick user)
|
readIORef state >>= flip issueToken (userNick user)
|
||||||
authMessage _ _ = return Nothing
|
authMessage _ _ = return []
|
||||||
|
|
||||||
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
|
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
|
||||||
stopAuth state = io $ do
|
stopAuth state = io $ do
|
||||||
|
|
|
@ -20,13 +20,13 @@ mkMsgHandler _ _ "help" =
|
||||||
helpMsg = "Get help. !help or !help <command>"
|
helpMsg = "Get help. !help or !help <command>"
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
mkMsgHandler _ _ _ = return Nothing
|
||||||
|
|
||||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
|
||||||
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
|
pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
|
||||||
io $ atomicWriteIORef state msgTime
|
io $ atomicWriteIORef state msgTime
|
||||||
return . Just $ PongCmd msg
|
return [PongCmd msg]
|
||||||
pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
|
pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
|
||||||
io $ atomicWriteIORef state msgTime
|
io $ atomicWriteIORef state msgTime
|
||||||
return Nothing
|
return []
|
||||||
pingPong state Message { msgDetails = IdleMsg { .. }, .. }
|
pingPong state Message { msgDetails = IdleMsg { .. }, .. }
|
||||||
| even (convert msgTime :: Int) = do
|
| even (convert msgTime :: Int) = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
|
@ -34,21 +34,21 @@ pingPong state Message { msgDetails = IdleMsg { .. }, .. }
|
||||||
io $ do
|
io $ do
|
||||||
lastComm <- readIORef state
|
lastComm <- readIORef state
|
||||||
if addUTCTime limit lastComm < msgTime
|
if addUTCTime limit lastComm < msgTime
|
||||||
then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
|
then return [PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime]
|
||||||
else return Nothing
|
else return []
|
||||||
|
|
||||||
pingPong _ _ = return Nothing
|
pingPong _ _ = return []
|
||||||
|
|
||||||
help :: MonadMsgHandler m => Message -> m (Maybe Command)
|
help :: MonadMsgHandler m => Message -> m [Command]
|
||||||
help Message { msgDetails = ChannelMsg { .. }, .. }
|
help Message { msgDetails = ChannelMsg { .. }, .. }
|
||||||
| "!help" == clean msg = do
|
| "!help" == clean msg = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
|
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
|
||||||
return . Just . ChannelMsgReply $ "I know these commands: " ++ unwords commands
|
return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
|
||||||
| "!help" `isPrefixOf` msg = do
|
| "!help" `isPrefixOf` msg = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
|
let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
|
||||||
let mHelp = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
|
let mHelp = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
|
||||||
return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
|
return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
|
||||||
|
|
||||||
help _ = return Nothing
|
help _ = return []
|
||||||
|
|
|
@ -12,22 +12,22 @@ mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greete
|
||||||
mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
mkMsgHandler _ _ _ = return Nothing
|
||||||
|
|
||||||
greeter :: MonadMsgHandler m => Message -> m (Maybe Command)
|
greeter :: MonadMsgHandler m => Message -> m [Command]
|
||||||
greeter Message { msgDetails = ChannelMsg { .. }, .. } =
|
greeter Message { msgDetails = ChannelMsg { .. }, .. } =
|
||||||
return . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
|
return . maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
|
||||||
. find (== clean msg) $ greetings
|
. find (== clean msg) $ greetings
|
||||||
where
|
where
|
||||||
greetings = [ "hi", "hello", "hey", "sup", "bye"
|
greetings = [ "hi", "hello", "hey", "sup", "bye"
|
||||||
, "good morning", "good evening", "good night" ]
|
, "good morning", "good evening", "good night" ]
|
||||||
greeter _ = return Nothing
|
greeter _ = return []
|
||||||
|
|
||||||
welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
|
welcomer :: MonadMsgHandler m => Message -> m [Command]
|
||||||
welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
|
welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
if userNick user /= botNick
|
if userNick user /= botNick
|
||||||
then return . Just . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
|
then return [ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)]
|
||||||
else return Nothing
|
else return []
|
||||||
|
|
||||||
welcomer _ = return Nothing
|
welcomer _ = return []
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -50,7 +50,7 @@ initMessageLogger botConfig state = do
|
||||||
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
|
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
|
||||||
exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
|
exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
|
||||||
|
|
||||||
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
|
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command]
|
||||||
withLogFile action state = do
|
withLogFile action state = do
|
||||||
botConfig <- ask
|
botConfig <- ask
|
||||||
io $ do
|
io $ do
|
||||||
|
@ -70,9 +70,9 @@ withLogFile action state = do
|
||||||
action logFileHandle'
|
action logFileHandle'
|
||||||
atomicWriteIORef state $ Just (logFileHandle', curDay)
|
atomicWriteIORef state $ Just (logFileHandle', curDay)
|
||||||
|
|
||||||
return Nothing
|
return []
|
||||||
|
|
||||||
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
|
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Command]
|
||||||
messageLogger Message { .. } = case msgDetails of
|
messageLogger Message { .. } = case msgDetails of
|
||||||
ChannelMsg { .. } -> log "<{}> {}" [nick user, msg]
|
ChannelMsg { .. } -> log "<{}> {}" [nick user, msg]
|
||||||
ActionMsg { .. } -> log "<{}> {} {}" [nick user, nick user, msg]
|
ActionMsg { .. } -> log "<{}> {} {}" [nick user, nick user, msg]
|
||||||
|
@ -82,7 +82,7 @@ messageLogger Message { .. } = case msgDetails of
|
||||||
QuitMsg { .. } -> log "** {} QUIT :{}" [nick user, msg]
|
QuitMsg { .. } -> log "** {} QUIT :{}" [nick user, msg]
|
||||||
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
|
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
|
||||||
NamesMsg { .. } -> log "** USERS {}" [unwords . map nickToText $ nicks]
|
NamesMsg { .. } -> log "** USERS {}" [unwords . map nickToText $ nicks]
|
||||||
_ -> const $ return Nothing
|
_ -> const $ return []
|
||||||
where
|
where
|
||||||
nick = nickToText . userNick
|
nick = nickToText . userNick
|
||||||
|
|
||||||
|
|
|
@ -55,24 +55,24 @@ data NickTrackingState = NickTrackingState { acid :: AcidState NickTr
|
||||||
, onlineNicks :: HashSet Nick
|
, onlineNicks :: HashSet Nick
|
||||||
, lastRefreshOn :: UTCTime }
|
, lastRefreshOn :: UTCTime }
|
||||||
|
|
||||||
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
|
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
|
||||||
nickTrackerMsg state message@Message { .. } = case msgDetails of
|
nickTrackerMsg state message@Message { .. } = case msgDetails of
|
||||||
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
|
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
|
||||||
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
|
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return []
|
||||||
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> add user >> return Nothing
|
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> add user >> return []
|
||||||
PartMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
|
PartMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return []
|
||||||
QuitMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
|
QuitMsg { .. } -> updateNickTrack state user msg msgTime >> remove user >> return []
|
||||||
NickMsg { .. } ->
|
NickMsg { .. } ->
|
||||||
handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return Nothing
|
handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return []
|
||||||
NamesMsg { .. } -> do
|
NamesMsg { .. } -> do
|
||||||
forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
|
forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
|
||||||
refresh nicks >> updateRefreshTime >> return Nothing
|
refresh nicks >> updateRefreshTime >> return []
|
||||||
IdleMsg { .. } -> do
|
IdleMsg { .. } -> do
|
||||||
NickTrackingState { .. } <- readIORef state
|
NickTrackingState { .. } <- readIORef state
|
||||||
if addUTCTime refreshInterval lastRefreshOn < msgTime
|
if addUTCTime refreshInterval lastRefreshOn < msgTime
|
||||||
then updateRefreshTime >> return (Just NamesCmd)
|
then updateRefreshTime >> return [NamesCmd]
|
||||||
else return Nothing
|
else return []
|
||||||
_ -> return Nothing
|
_ -> return []
|
||||||
where
|
where
|
||||||
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
|
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
|
||||||
|
|
||||||
|
@ -89,7 +89,7 @@ nickTrackerMsg state message@Message { .. } = case msgDetails of
|
||||||
, ("!forgetnicks", handleForgetNicksCommand)]
|
, ("!forgetnicks", handleForgetNicksCommand)]
|
||||||
|
|
||||||
handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
|
handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
|
||||||
Nothing -> return Nothing
|
Nothing -> return []
|
||||||
Just (_, handler) -> handler state message
|
Just (_, handler) -> handler state message
|
||||||
|
|
||||||
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
|
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
|
||||||
|
@ -127,26 +127,26 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
|
||||||
|
|
||||||
withNickTracks :: MonadMsgHandler m
|
withNickTracks :: MonadMsgHandler m
|
||||||
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
|
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
|
||||||
-> m (Maybe Command)
|
-> m [Command]
|
||||||
withNickTracks f state message = io $ do
|
withNickTracks f state message = io $ do
|
||||||
NickTrackingState { .. } <- readIORef state
|
NickTrackingState { .. } <- readIORef state
|
||||||
let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
|
let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
|
||||||
if nick == ""
|
if nick == ""
|
||||||
then return Nothing
|
then return []
|
||||||
else do
|
else do
|
||||||
mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
|
mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
|
||||||
map (Just . ChannelMsgReply) $ case mcn of
|
map (singleton . ChannelMsgReply) $ case mcn of
|
||||||
Nothing -> return $ "Unknown nick: " ++ nick
|
Nothing -> return $ "Unknown nick: " ++ nick
|
||||||
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
|
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
|
||||||
|
|
||||||
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
|
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
|
||||||
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
|
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
|
||||||
let nicks = map ((\(Nick n) -> n) . nick) nickTracks
|
let nicks = map ((\(Nick n) -> n) . nick) nickTracks
|
||||||
if length nicks == 1
|
if length nicks == 1
|
||||||
then return $ nck ++ " has only one nick"
|
then return $ nck ++ " has only one nick"
|
||||||
else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
|
else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
|
||||||
|
|
||||||
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
|
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
|
||||||
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
|
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
|
||||||
let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
|
let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
|
||||||
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
|
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
|
||||||
|
@ -164,7 +164,7 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
|
||||||
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
|
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
|
||||||
" said: " ++ lastMessage')
|
" said: " ++ lastMessage')
|
||||||
|
|
||||||
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
|
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
|
||||||
handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
|
handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
|
||||||
NickTrackingState { .. } <- readIORef state
|
NickTrackingState { .. } <- readIORef state
|
||||||
let nick = userNick user
|
let nick = userNick user
|
||||||
|
@ -172,7 +172,14 @@ handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } =
|
||||||
Just nt <- getByNick acid nick
|
Just nt <- getByNick acid nick
|
||||||
cn <- newCanonicalNick
|
cn <- newCanonicalNick
|
||||||
saveNickTrack acid $ nt { canonicalNick = cn }
|
saveNickTrack acid $ nt { canonicalNick = cn }
|
||||||
return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
|
return [ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
|
||||||
|
|
||||||
|
nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> SomeEvent -> m EventResponse
|
||||||
|
nickTrackerEvent state event = case fromEvent event of
|
||||||
|
Just (NickTrackRequest nick reply, _) -> io $ do
|
||||||
|
NickTrackingState { .. } <- readIORef state
|
||||||
|
getByNick acid nick >>= putMVar reply >> return RespNothing
|
||||||
|
_ -> return RespNothing
|
||||||
|
|
||||||
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
|
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
|
||||||
stopNickTracker state = io $ do
|
stopNickTracker state = io $ do
|
||||||
|
@ -188,11 +195,12 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
|
||||||
acid <- openLocalState emptyNickTracking
|
acid <- openLocalState emptyNickTracking
|
||||||
newIORef (NickTrackingState acid refreshInterval mempty now)
|
newIORef (NickTrackingState acid refreshInterval mempty now)
|
||||||
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
|
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
|
||||||
|
, onEvent = nickTrackerEvent state
|
||||||
, onStop = stopNickTracker state
|
, onStop = stopNickTracker state
|
||||||
, onHelp = return helpMsgs }
|
, onHelp = return helpMsgs }
|
||||||
where
|
where
|
||||||
helpMsgs = mapFromList [
|
helpMsgs = mapFromList [
|
||||||
("!nicks", "Shows alternate nicks of the user. !nicks <user nick>"),
|
("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
|
||||||
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
|
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
|
||||||
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
|
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
|
||||||
mkMsgHandler _ _ _ = return Nothing
|
mkMsgHandler _ _ _ = return Nothing
|
||||||
|
|
|
@ -3,9 +3,10 @@
|
||||||
module Network.IRC.Handlers.NickTracker.Types where
|
module Network.IRC.Handlers.NickTracker.Types where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Data.Data (Data)
|
import Control.Concurrent.Lifted (Chan, writeChan)
|
||||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
import Data.Data (Data)
|
||||||
import Data.SafeCopy (base, deriveSafeCopy)
|
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
|
|
||||||
import Network.IRC.Types
|
import Network.IRC.Types
|
||||||
|
|
||||||
|
@ -35,3 +36,17 @@ $(deriveSafeCopy 0 'base ''NickTracking)
|
||||||
|
|
||||||
emptyNickTracking :: NickTracking
|
emptyNickTracking :: NickTracking
|
||||||
emptyNickTracking = NickTracking empty
|
emptyNickTracking = NickTracking empty
|
||||||
|
|
||||||
|
data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable)
|
||||||
|
|
||||||
|
instance Event NickTrackRequest
|
||||||
|
|
||||||
|
instance Show NickTrackRequest where
|
||||||
|
show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
|
||||||
|
|
||||||
|
getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
|
||||||
|
getCanonicalNick eventChan nick = do
|
||||||
|
reply <- newEmptyMVar
|
||||||
|
request <- toEvent $ NickTrackRequest nick reply
|
||||||
|
writeChan eventChan request
|
||||||
|
map (map canonicalNick) $ takeMVar reply
|
||||||
|
|
|
@ -37,14 +37,14 @@ instance FromJSON Song where
|
||||||
parseJSON a | a == emptyArray = return NoSong
|
parseJSON a | a == emptyArray = return NoSong
|
||||||
parseJSON _ = mempty
|
parseJSON _ = mempty
|
||||||
|
|
||||||
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
|
songSearch :: MonadMsgHandler m => Message -> m [Command]
|
||||||
songSearch Message { msgDetails = ChannelMsg { .. }, .. }
|
songSearch Message { msgDetails = ChannelMsg { .. }, .. }
|
||||||
| "!m " `isPrefixOf` msg = do
|
| "!m " `isPrefixOf` msg = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
let query = strip . drop 3 $ msg
|
let query = strip . drop 3 $ msg
|
||||||
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
||||||
map (Just . ChannelMsgReply) $ case mApiKey of
|
map (singleton . ChannelMsgReply) $ case mApiKey of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
errorM "tinysong api key not found in config"
|
errorM "tinysong api key not found in config"
|
||||||
return $ "Error while searching for " ++ query
|
return $ "Error while searching for " ++ query
|
||||||
|
@ -58,5 +58,5 @@ songSearch Message { msgDetails = ChannelMsg { .. }, .. }
|
||||||
Right song -> case song of
|
Right song -> case song of
|
||||||
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
||||||
NoSong -> "No song found for: " ++ query
|
NoSong -> "No song found for: " ++ query
|
||||||
| otherwise = return Nothing
|
| otherwise = return []
|
||||||
songSearch _ = return Nothing
|
songSearch _ = return []
|
||||||
|
|
|
@ -0,0 +1,129 @@
|
||||||
|
{-# LANGUAGE PatternGuards #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Network.IRC.Handlers.Tell (mkMsgHandler) where
|
||||||
|
|
||||||
|
import qualified Data.IxSet as IS
|
||||||
|
|
||||||
|
import ClassyPrelude hiding (swap)
|
||||||
|
import Control.Concurrent.Lifted (Chan)
|
||||||
|
import Control.Monad.Reader (ask)
|
||||||
|
import Control.Monad.State (get, put)
|
||||||
|
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
|
||||||
|
openLocalState, createArchive)
|
||||||
|
import Data.Acid.Local (createCheckpointAndClose)
|
||||||
|
import Data.IxSet ((@=))
|
||||||
|
import Data.Text (split, strip)
|
||||||
|
|
||||||
|
import Network.IRC.Handlers.NickTracker.Types
|
||||||
|
import Network.IRC.Handlers.Tell.Types
|
||||||
|
import Network.IRC.Types
|
||||||
|
import Network.IRC.Util
|
||||||
|
|
||||||
|
getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell]
|
||||||
|
getUndeliveredTellsQ nick = do
|
||||||
|
Tells { .. } <- ask
|
||||||
|
return . sortBy (comparing tellCreatedOn) . IS.toList $ tells @= nick @= NewTell
|
||||||
|
|
||||||
|
saveTellQ :: Tell -> Update Tells ()
|
||||||
|
saveTellQ tell@Tell { .. } = do
|
||||||
|
Tells { .. } <- get
|
||||||
|
if tellId == -1
|
||||||
|
then put $ Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells)
|
||||||
|
else put $ Tells nextTellId (IS.updateIx tellId tell tells)
|
||||||
|
|
||||||
|
$(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ])
|
||||||
|
|
||||||
|
getUndeliveredTells :: AcidState Tells -> CanonicalNick -> IO [Tell]
|
||||||
|
getUndeliveredTells acid = query acid . GetUndeliveredTellsQ
|
||||||
|
|
||||||
|
saveTell :: AcidState Tells -> Tell -> IO ()
|
||||||
|
saveTell acid = update acid . SaveTellQ
|
||||||
|
|
||||||
|
newtype TellState = TellState { acid :: AcidState Tells }
|
||||||
|
|
||||||
|
tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message -> m [Command]
|
||||||
|
tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
|
||||||
|
| command == "!tell"
|
||||||
|
, args <- drop 1 . words $ msg
|
||||||
|
, length args >= 2 = io $ do
|
||||||
|
TellState { .. } <- readIORef state
|
||||||
|
reps <- if "<" `isPrefixOf` headEx args
|
||||||
|
then do
|
||||||
|
let (nicks, message) =
|
||||||
|
(parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
|
||||||
|
|
||||||
|
if null message
|
||||||
|
then return []
|
||||||
|
else do
|
||||||
|
res <- forM nicks $ \nick -> handleTell acid nick message
|
||||||
|
let (fails, passes) = partitionEithers res
|
||||||
|
let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
|
||||||
|
(if null passes then [] else
|
||||||
|
["Message noted and will be passed on to " ++ intercalate ", " passes])
|
||||||
|
return reps
|
||||||
|
else do
|
||||||
|
let nick = Nick . headEx $ args
|
||||||
|
let message = strip . unwords . drop 1 $ args
|
||||||
|
if null message
|
||||||
|
then return []
|
||||||
|
else do
|
||||||
|
res <- handleTell acid nick message
|
||||||
|
let rep = case res of
|
||||||
|
Left _ -> "Unknown nick: " ++ nickToText nick
|
||||||
|
Right _ -> "Message noted and will be passed on to " ++ nickToText nick
|
||||||
|
return [rep]
|
||||||
|
tells <- getTellsToDeliver
|
||||||
|
return . map textToReply $ (reps ++ tells)
|
||||||
|
| otherwise = io $ map (map textToReply) getTellsToDeliver
|
||||||
|
where
|
||||||
|
command = clean . fromMaybe "" $ headMay . words $ msg
|
||||||
|
|
||||||
|
parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
|
||||||
|
|
||||||
|
textToReply t = ChannelMsgReply $ nickToText (userNick user) ++ ": " ++ t
|
||||||
|
|
||||||
|
tellToMsg Tell { .. } =
|
||||||
|
relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
|
||||||
|
|
||||||
|
newTell canonicalNick = Tell (-1) (userNick user) canonicalNick Nothing NewTell msgTime Nothing
|
||||||
|
|
||||||
|
getTellsToDeliver = io $ do
|
||||||
|
TellState { .. } <- readIORef state
|
||||||
|
mcn <- getCanonicalNick eventChan $ userNick user
|
||||||
|
case mcn of
|
||||||
|
Nothing -> return []
|
||||||
|
Just canonicalNick -> do
|
||||||
|
tells <- getUndeliveredTells acid canonicalNick
|
||||||
|
forM tells $ \tell -> do
|
||||||
|
saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
|
||||||
|
return . tellToMsg $ tell
|
||||||
|
|
||||||
|
handleTell acid nick message = do
|
||||||
|
mcn <- getCanonicalNick eventChan nick
|
||||||
|
case mcn of
|
||||||
|
Nothing -> return . Left . nickToText $ nick
|
||||||
|
Just canonicalNick ->
|
||||||
|
saveTell acid (newTell canonicalNick message) >> (return . Right . nickToText $ nick)
|
||||||
|
|
||||||
|
tellMsg _ _ _ = return []
|
||||||
|
|
||||||
|
stopTell :: MonadMsgHandler m => IORef TellState -> m ()
|
||||||
|
stopTell state = io $ do
|
||||||
|
TellState { .. } <- readIORef state
|
||||||
|
createArchive acid
|
||||||
|
createCheckpointAndClose acid
|
||||||
|
|
||||||
|
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||||
|
mkMsgHandler BotConfig { .. } eventChan "tells" = do
|
||||||
|
acid <- openLocalState emptyTells
|
||||||
|
state <- newIORef (TellState acid)
|
||||||
|
return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
|
||||||
|
, onStop = stopTell state
|
||||||
|
, onHelp = return helpMsgs }
|
||||||
|
where
|
||||||
|
helpMsgs = mapFromList [
|
||||||
|
("!tell", "Publically passes a message to a user or a bunch of users. " ++
|
||||||
|
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>") ]
|
||||||
|
mkMsgHandler _ _ _ = return Nothing
|
|
@ -0,0 +1,43 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module Network.IRC.Handlers.Tell.Types where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Data.Data (Data)
|
||||||
|
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||||
|
import Data.SafeCopy (base, deriveSafeCopy)
|
||||||
|
|
||||||
|
import Network.IRC.Handlers.NickTracker.Types
|
||||||
|
import Network.IRC.Types
|
||||||
|
|
||||||
|
newtype TellId = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
|
||||||
|
data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
|
||||||
|
|
||||||
|
data Tell = Tell {
|
||||||
|
tellId :: !TellId,
|
||||||
|
tellFromNick :: !Nick,
|
||||||
|
tellToNick :: !CanonicalNick,
|
||||||
|
tellTopic :: !(Maybe Text),
|
||||||
|
tellStatus :: !TellStatus,
|
||||||
|
tellCreatedOn :: !UTCTime,
|
||||||
|
tellDeliveredOn :: !(Maybe UTCTime),
|
||||||
|
tellContent :: !Text
|
||||||
|
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||||
|
|
||||||
|
instance Indexable Tell where
|
||||||
|
empty = ixSet [ ixFun $ (: []) . tellId
|
||||||
|
, ixFun $ (: []) . tellToNick
|
||||||
|
, ixFun $ (: []) . tellStatus ]
|
||||||
|
|
||||||
|
data Tells = Tells { nextTellId :: TellId, tells :: IxSet Tell }
|
||||||
|
deriving (Eq, Ord, Show, Data, Typeable)
|
||||||
|
|
||||||
|
$(deriveSafeCopy 0 'base ''TellId)
|
||||||
|
$(deriveSafeCopy 0 'base ''TellStatus)
|
||||||
|
$(deriveSafeCopy 0 'base ''Tell)
|
||||||
|
$(deriveSafeCopy 0 'base ''Tells)
|
||||||
|
|
||||||
|
emptyTells :: Tells
|
||||||
|
emptyTells = Tells (TellId 1) empty
|
|
@ -83,7 +83,9 @@ library
|
||||||
Network.IRC.Handlers.MessageLogger,
|
Network.IRC.Handlers.MessageLogger,
|
||||||
Network.IRC.Handlers.NickTracker,
|
Network.IRC.Handlers.NickTracker,
|
||||||
Network.IRC.Handlers.NickTracker.Types,
|
Network.IRC.Handlers.NickTracker.Types,
|
||||||
Network.IRC.Handlers.SongSearch
|
Network.IRC.Handlers.SongSearch,
|
||||||
|
Network.IRC.Handlers.Tell,
|
||||||
|
Network.IRC.Handlers.Tell.Types
|
||||||
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue