From 861fb8c2b91dc3be92b4ff63426de393d1a9949f Mon Sep 17 00:00:00 2001 From: YuriRomanowski <119875599+YuriRomanowski@users.noreply.github.com> Date: Fri, 10 Feb 2023 21:19:59 +0500 Subject: [PATCH] [#22] Revise messages editing (#54) Problem: Currently message_changed event is handled by translating new time references and sending ephemeral with them, which can be inconvenient sometimes. Solution: On message_changed event send an ephemeral containing message permalink and all message time references translated. --- package.yaml | 1 + src/TzBot/BotMain.hs | 8 +- src/TzBot/Cache.hs | 14 +- src/TzBot/Feedback/Dialog.hs | 2 +- src/TzBot/Logger.hs | 4 + src/TzBot/ProcessEvents.hs | 2 - src/TzBot/ProcessEvents/Message.hs | 306 ++++++++++++++++------------- src/TzBot/Render.hs | 2 +- src/TzBot/RunMonad.hs | 6 +- src/TzBot/Slack.hs | 21 +- src/TzBot/Slack/API.hs | 8 +- src/TzBot/Util.hs | 3 + 12 files changed, 223 insertions(+), 154 deletions(-) diff --git a/package.yaml b/package.yaml index 05d3ec3..e714b1f 100644 --- a/package.yaml +++ b/package.yaml @@ -72,6 +72,7 @@ library: - utf8-string - validation - yaml + - utf8-string executables: tzbot-exe: diff --git a/src/TzBot/BotMain.hs b/src/TzBot/BotMain.hs index 81fb1c8..8ae6f4f 100644 --- a/src/TzBot/BotMain.hs +++ b/src/TzBot/BotMain.hs @@ -8,7 +8,6 @@ import Universum import Control.Monad.Managed (managed, runManaged) import Data.ByteString qualified as BS -import Data.Map qualified as M import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Options.Applicative (execParser) @@ -17,6 +16,7 @@ import Slacker setGracefulShutdownHandler, setOnException) import System.Directory (doesFileExist) import Text.Interpolation.Nyan (int, rmode') +import Time (hour) import TzBot.Cache (TzCacheSettings(tcsExpiryRandomAmplitudeFraction), defaultTzCacheSettings, withTzCache, @@ -78,13 +78,17 @@ run opts = do & setGracefulShutdownHandler extractShutdownFunction bsManager <- liftIO $ newManager tlsManagerSettings - bsMessagesReferences <- newIORef M.empty bsFeedbackConfig <- managed $ withFeedbackConfig bsConfig bsUserInfoCache <- managed $ withTzCache fifteenPercentAmplitudeSettings cCacheUsersInfo bsConversationMembersCache <- managed $ withTzCache fifteenPercentAmplitudeSettings cCacheConversationMembers + let defaultMessageInfoCachingTime = hour 1 + bsMessageCache <- + managed $ withTzCacheDefault defaultMessageInfoCachingTime + bsMessageLinkCache <- + managed $ withTzCacheDefault defaultMessageInfoCachingTime bsReportEntries <- managed $ withTzCacheDefault cCacheReportDialog -- auto-acknowledge received messages diff --git a/src/TzBot/Cache.hs b/src/TzBot/Cache.hs index 7e3b94a..7c72fea 100644 --- a/src/TzBot/Cache.hs +++ b/src/TzBot/Cache.hs @@ -16,8 +16,8 @@ module TzBot.Cache , lookup -- * Altering cache - , insertRandomized - , fetchWithCacheRandomized + , insert + , fetchWithCache , update ) where @@ -106,13 +106,13 @@ cleaningThread cleaningPeriod cache = forever $ do -- | Generate a random expiry time and insert a key/value pair into -- the cache with that expiry time. -insertRandomized +insert :: (Eq k, Hashable k, MonadIO m) => k -> v -> TzCache k v -> m () -insertRandomized key val TzCache {..} = do +insert key val TzCache {..} = do expiry <- case rcExpiryRandomAmplitude of Nothing -> pure rcExpiry Just randAmp -> do @@ -124,13 +124,13 @@ insertRandomized key val TzCache {..} = do -- If the value is either absent or expired, perform given fetch action -- and insert the obtained value with configured expiration parameters -- into the cache. -fetchWithCacheRandomized +fetchWithCache :: (Eq k, Hashable k, MonadIO m, KatipContext m, Buildable k) => k -> (k -> m v) -> TzCache k v -> m v -fetchWithCacheRandomized key fetchAction cache = +fetchWithCache key fetchAction cache = katipAddNamespace "cache" $ do logDebug [int||Fetching key=#{key}|] mv <- liftIO $ Cache.lookup (rcCache cache) key @@ -142,7 +142,7 @@ fetchWithCacheRandomized key fetchAction cache = using provided fetching action |] v <- fetchAction key - insertRandomized key v cache + insert key v cache pure v lookup diff --git a/src/TzBot/Feedback/Dialog.hs b/src/TzBot/Feedback/Dialog.hs index 499003a..b6f6dd0 100644 --- a/src/TzBot/Feedback/Dialog.hs +++ b/src/TzBot/Feedback/Dialog.hs @@ -20,7 +20,7 @@ import TzBot.RunMonad (BotM, BotState(bsReportEntries)) insertDialogEntry :: ReportDialogId -> ReportDialogEntry -> BotM () insertDialogEntry id_ entry = do dialogEntriesCache <- asks bsReportEntries - Cache.insertRandomized id_ entry dialogEntriesCache + Cache.insert id_ entry dialogEntriesCache lookupDialogEntry :: ReportDialogId -> BotM (Maybe ReportDialogEntry) lookupDialogEntry id_ = do diff --git a/src/TzBot/Logger.hs b/src/TzBot/Logger.hs index df8c661..e81054e 100644 --- a/src/TzBot/Logger.hs +++ b/src/TzBot/Logger.hs @@ -14,6 +14,7 @@ import Universum import Data.Aeson (KeyValue((.=)), ToJSON(..), object) import Katip +import Text.Interpolation.Nyan (int, rmode's) import TzBot.Slack.API (MessageId(..)) @@ -26,6 +27,9 @@ logWarn t = withFrozenCallStack $ logSugar_ WarningS t logDebug t = withFrozenCallStack $ logSugar_ DebugS t logError t = withFrozenCallStack $ logSugar_ ErrorS t +logException :: (Exception e, KatipContext m) => e -> m () +logException err = logError [int||Error occured: #s{err}|] + withLogger :: Severity -> ((Namespace, LogContexts, LogEnv) -> IO a) diff --git a/src/TzBot/ProcessEvents.hs b/src/TzBot/ProcessEvents.hs index 7f03321..adadbae 100644 --- a/src/TzBot/ProcessEvents.hs +++ b/src/TzBot/ProcessEvents.hs @@ -87,8 +87,6 @@ handler shutdownRef bState _cfg e = run $ do run action = void $ runBotM bState $ do eithRes <- catchAllErrors action whenLeft eithRes $ \eithErr -> do - let logException :: (Exception e) => e -> BotM () - logException err = logError [int||Error occured: #s{err}|] case eithErr of Left someExc | Just UserInterrupt <- fromException someExc -> diff --git a/src/TzBot/ProcessEvents/Message.hs b/src/TzBot/ProcessEvents/Message.hs index f7f0e39..f4dd901 100644 --- a/src/TzBot/ProcessEvents/Message.hs +++ b/src/TzBot/ProcessEvents/Message.hs @@ -9,13 +9,14 @@ module TzBot.ProcessEvents.Message import Universum hiding (try) import Control.Concurrent.Async.Lifted (forConcurrently) +import Data.List (singleton) import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M import Data.Set qualified as S import Data.Text.Lazy.Builder (Builder) import System.Random (randomRIO) import Text.Interpolation.Nyan (int, rmode', rmode's) +import TzBot.Cache qualified as Cache import TzBot.Config (Config(..)) import TzBot.Logger import TzBot.ProcessEvents.Common (getTimeReferencesFromMessage) @@ -24,63 +25,34 @@ import TzBot.Slack import TzBot.Slack.API import TzBot.Slack.Events import TzBot.Slack.Fixtures qualified as Fixtures -import TzBot.TimeReference (TimeReference(trText), TimeReferenceText) -import TzBot.Util (catchAllErrors, isDevEnvironment, withMaybe) - --- Helper function for `filterNewReferencesAndMemorize` -filterNewReferencesAndMemorizePure - :: [TimeReference] - -> S.Set TimeReferenceText - -> (S.Set TimeReferenceText, [TimeReference]) -filterNewReferencesAndMemorizePure newRefs refsSet = - foldl' f (refsSet, []) newRefs - where - f (accSet, accRefs) ref = do - let newAccSet = S.insert (trText ref) accSet - if S.size newAccSet == S.size accSet - then (newAccSet, accRefs) - else (newAccSet, ref : accRefs) - --- | When an edited message comes, define what time references in it --- haven't appear before and record them in the bot's state. -filterNewReferencesAndMemorize - :: MessageId - -> [TimeReference] - -> BotM (Maybe (NE.NonEmpty TimeReference)) -filterNewReferencesAndMemorize messageId timeRefs = NE.nonEmpty <$> do - processedRefsIORef <- asks bsMessagesReferences - atomicModifyIORef' processedRefsIORef $ \refsMap -> do - flip runState timeRefs $ M.alterF f messageId refsMap - where - f :: Maybe (S.Set TimeReferenceText) - -> State [TimeReference] (Maybe (S.Set TimeReferenceText)) - f mbSet = state $ \refs -> do - case mbSet of - Nothing -> (Just $ S.fromList $ map trText refs, refs) - Just set -> bimap Just reverse $ filterNewReferencesAndMemorizePure refs set +import TzBot.TimeReference (TimeReference(..)) +import TzBot.Util (catchAllErrors, isDevEnvironment, whenT, withMaybe) + +data MessageEventType = METMessage | METMessageEdited + deriving stock (Eq) -- We don't need to handle MDMessageBroadcast anyhow, -- because we were supposed to reply to the original message -- in the thread earlier. -- channel_join and channel_leave messages are also ignored because -- we handle these events in another way. -filterMessageTypeWithLog :: (KatipContext m) => MessageEvent -> m Bool +filterMessageTypeWithLog :: (KatipContext m) => MessageEvent -> m (Maybe MessageEventType) filterMessageTypeWithLog evt = case meMessageDetails evt of MDMessage -> do logInfo [int||Handling new message|] - pure True + pure $ Just METMessage MDMessageEdited {} -> do logInfo [int||Message was edited|] - pure True + pure $ Just METMessageEdited MDMessageBroadcast -> do logInfo [int||Incoming message is thread broadcast, ignoring|] - pure False + pure Nothing MDUserJoinedChannel -> do logInfo [int||Incoming message subtype=channel_join, ignoring|] - pure False + pure Nothing MDUserLeftChannel -> do logInfo [int||Incoming message subtype=channel_leave, ignoring|] - pure False + pure Nothing withSenderNotBot :: MessageEvent -> BotM (Maybe User) withSenderNotBot evt = do @@ -105,97 +77,165 @@ withSenderNotBot evt = do processMessageEvent :: MessageEvent -> BotM () processMessageEvent evt = katipAddNamespaceText "message" $ - katipAddContext (MessageContext (mMessageId $ meMessage evt)) $ - whenM (filterMessageTypeWithLog evt) $ - whenJustM (withSenderNotBot evt) $ \sender -> do - let msg = meMessage evt - - -- TODO: use some "transactions here"? Or just lookup the map multiple times. - timeRefs <- getTimeReferencesFromMessage msg - mbReferencesToCheck <- - filterNewReferencesAndMemorize (mMessageId msg) timeRefs - withMaybe mbReferencesToCheck - (logInfo "No time references for processing found") - \timeRefs -> do - inverseChance <- asks $ cInverseHelpUsageChance . bsConfig + katipAddContext (MessageContext msgId) $ + whenJustM (filterMessageTypeWithLog evt) $ \mEventType -> + whenJustM (withSenderNotBot evt) $ \sender -> do + timeRefs <- getTimeReferencesFromMessage msg + processMessageEvent' evt mEventType sender timeRefs + where + msg = meMessage evt + msgId = mMessageId $ meMessage evt - whetherToShowHelpCmd <- liftIO $ fmap (== 1) $ randomRIO (1, inverseChance) - when whetherToShowHelpCmd $ logDebug "appending help command usage" - - let now = meTs evt - channelId = meChannel evt - let sendAction :: SenderFlag -> TranslationPairs -> UserId -> BotM () - sendAction toSender transl userId = do - let req = PostEphemeralReq - { perUser = userId - , perChannel = channelId - , perThreadTs = mThreadId msg - , perText = joinTranslationPairs toSender transl - , perBlocks = NE.nonEmpty $ - renderSlackBlocks toSender (Just transl) <> - [ BSection $ markdownSection (Mrkdwn Fixtures.helpUsage) - | whetherToShowHelpCmd - ] - } - sendEphemeralMessage req - let ephemeralTemplate = renderTemplate now sender timeRefs - case meChannelType evt of - -- According to - -- https://forums.slackcommunity.com/s/question/0D53a00008vsItQCAU - -- it's not possible to add the bot to any existing DMs, so if - -- the channel type of the message event is DM, it can only be - -- the user-bot conversation. This means that the user wants - -- to translate some time references and we send the translation - -- only to him, showing it in the way how other users would see - -- it if it were sent to the common channel. - Just CTDirectChannel -> do - let ephemeralMessage = renderAllForOthersTP sender ephemeralTemplate - logInfo [int||Received message from the DM, sending translation \ - to the author|] - sendAction asForOthersS ephemeralMessage (uId sender) - _ -> do - usersInChannelIds <- getChannelMembersCached channelId - - whenJust (renderErrorsForSenderTP ephemeralTemplate) $ \errorsMsg -> do - logInfo - [int||Found invalid time references, \ - sending an ephemeral with them to the message sender|] - sendAction asForSenderS errorsMsg (uId sender) - - let notBotAndSameTimeZone u = not (uIsBot u) && uTz u /= uTz sender - notSender userId = userId /= uId sender - setSize = S.size usersInChannelIds - - logInfo [int||#{setSize} users in the channel #{channelId}, sending ephemerals|] - eithRes <- forConcurrently (toList usersInChannelIds) $ \userInChannelId -> catchAllErrors $ - if isDevEnvironment - then do - userInChannel <- getUserCached userInChannelId - let ephemeralMessage = renderAllForOthersTP userInChannel ephemeralTemplate - sendAction asForOthersS ephemeralMessage (uId userInChannel) +processMessageEvent' + :: MessageEvent + -> MessageEventType + -> User + -> [TimeReference] + -> BotM () +processMessageEvent' evt mEventType sender timeRefs = + case meChannelType evt of + Just CTDirectChannel -> handleDirectMessage + _ -> case mEventType of + METMessageEdited -> handleMessageChanged + METMessage -> handleNewMessage + + where + + msg = meMessage evt + msgId = mMessageId msg + channelId = meChannel evt + now = meTs evt + mbThreadId = mThreadId msg + + notBot u = not (uIsBot u) + notSameTimeZone u = uTz u /= uTz sender + notBotAndSameTimeZone u = notBot u && notSameTimeZone u + + getWhetherToShowHelpCmd :: BotM Bool + getWhetherToShowHelpCmd = do + inverseChance <- asks $ cInverseHelpUsageChance . bsConfig + liftIO $ fmap (== 1) $ randomRIO (1, inverseChance) + + logNoTimeRefsFound :: KatipContext m => m () + logNoTimeRefsFound = logInfo "No time references for processing found" + + withNonEmptyTimeRefs + :: (KatipContext m) + => [TimeReference] + -> (NonEmpty TimeReference -> m ()) + -> m () + withNonEmptyTimeRefs trs action = + maybe logNoTimeRefsFound action (nonEmpty trs) + + sendAction + :: Maybe Text + -> SenderFlag + -> TranslationPairs + -> UserId + -> BotM () + sendAction mbPermalinkForEdit toSender transl userId = do + whetherToShowHelpCmd <- getWhetherToShowHelpCmd + let mbEditBlock = + withMaybe mbPermalinkForEdit [] \permalink -> + singleton $ BSection $ + markdownSection $ Mrkdwn [int|| + <#{permalink}|Message #{msgId}> has been edited: + |] + + let req = PostEphemeralReq + { perUser = userId + , perChannel = channelId + , perThreadTs = mbThreadId + , perText = joinTranslationPairs toSender transl + , perBlocks = NE.nonEmpty $ concat + [ mbEditBlock + , renderSlackBlocks toSender (Just transl) + , [ BSection $ markdownSection (Mrkdwn Fixtures.helpUsage) + | whetherToShowHelpCmd ] + ] + } + sendEphemeralMessage req + + handleMessageChanged :: BotM () + handleMessageChanged = katipAddNamespaceText "edit" do + messageRefsCache <- asks bsMessageCache + mbMessageRefs <- Cache.lookup msgId messageRefsCache + -- if not found or expired, just ignore this message + -- it's too old or just didn't contain any time refs + whenJust mbMessageRefs $ \oldRefs -> do + let newRefsFound = not $ all (`elem` oldRefs) timeRefs + -- no new references found, ignoring + when newRefsFound $ withNonEmptyTimeRefs timeRefs \neTimeRefs -> do + Cache.insert msgId timeRefs messageRefsCache + permalink <- getMessagePermalinkCached channelId msgId + handleChannelMessageCommon (Just permalink) neTimeRefs + + handleNewMessage :: BotM () + handleNewMessage = do + withNonEmptyTimeRefs timeRefs $ \neTimeRefs -> do + -- save message only if time references are present + asks bsMessageCache >>= Cache.insert msgId timeRefs + handleChannelMessageCommon Nothing neTimeRefs + + handleChannelMessageCommon :: Maybe Text -> NonEmpty TimeReference -> BotM () + handleChannelMessageCommon mbPermalink neTimeRefs = do + let ephemeralTemplate = renderTemplate now sender neTimeRefs + whenJust (renderErrorsForSenderTP ephemeralTemplate) $ \errorsMsg -> do + logInfo + [int|n| + Found invalid time references, + sending an ephemeral with them to the message sender + |] + sendAction mbPermalink asForSenderS errorsMsg (uId sender) + + let sendActionLocal userInChannelId = do + userInChannel <- getUserCached userInChannelId + whenT (isDevEnvironment || notBotAndSameTimeZone userInChannel) do + let ephemeralMessage = + renderAllForOthersTP userInChannel ephemeralTemplate + sendAction mbPermalink asForOthersS ephemeralMessage (uId userInChannel) pure True - else do - let whenT :: (Monad m) => Bool -> m Bool -> m Bool - whenT cond_ action_ = if cond_ then action_ else pure False - whenT (notSender userInChannelId) $ do - userInChannel <- getUserCached userInChannelId - whenT (notBotAndSameTimeZone userInChannel) $ do - let ephemeralMessage = renderAllForOthersTP userInChannel ephemeralTemplate - sendAction asForOthersS ephemeralMessage (uId userInChannel) - pure True - - let failedMsg = "Ephemeral sending failed" :: Builder - logAll :: Either SomeException BotException -> BotM () - logAll (Left se) = logError [int||#{failedMsg}, unknown error occured: #s{se}|] - logAll (Right ke) = logError [int||#{failedMsg}, #{displayException ke}|] - - processResult - :: (Int, Int) - -> Either (Either SomeException BotException) Bool - -> BotM (Int, Int) - processResult (oks_, errs_) eithRes_ = case eithRes_ of - Left err_ -> logAll err_ >> pure (oks_, errs_ + 1) - Right ok_ -> let oks_' = if ok_ then oks_ + 1 else oks_ in pure (oks_', errs_) - (oks, errs) <- foldM processResult (0, 0) eithRes - logInfo [int||#{oks} ephemeral sent successfully|] - logInfo [int||#{errs} ephemerals failed|] + ephemeralsMailing channelId sendActionLocal + + handleDirectMessage :: BotM () + handleDirectMessage = + when (mEventType /= METMessageEdited) $ + withNonEmptyTimeRefs timeRefs $ \neTimeRefs -> do + -- According to + -- https://forums.slackcommunity.com/s/question/0D53a00008vsItQCAU + -- it's not possible to add the bot to any existing DMs, so if + -- the channel type of the message event is DM, it can only be + -- the user-bot conversation. This means that the user wants + -- to translate some time references and we send the translation + -- only to him, showing it in the way how other users would see + -- it if it were sent to the common channel. + let ephemeralTemplate = renderTemplate now sender neTimeRefs + let ephemeralMessage = renderAllForOthersTP sender ephemeralTemplate + logInfo [int|| + Received message from the DM, sending translation to the author|] + sendAction Nothing asForOthersS ephemeralMessage (uId sender) + +ephemeralsMailing + :: ChannelId + -> (UserId -> BotM Bool) + -> BotM () +ephemeralsMailing channelId sendAction = do + usersInChannelIds <- getChannelMembersCached channelId + let setSize = S.size usersInChannelIds + logInfo [int||#{setSize} users in the channel #{channelId}, sending ephemerals|] + eithRes <- forConcurrently (toList usersInChannelIds) $ catchAllErrors . sendAction + let failedMsg = "Ephemeral sending failed" :: Builder + logAll :: Either SomeException BotException -> BotM () + logAll (Left se) = logError [int||#{failedMsg}, unknown error occured: #s{se}|] + logAll (Right ke) = logError [int||#{failedMsg}, #{displayException ke}|] + + processResult + :: (Int, Int) + -> Either (Either SomeException BotException) Bool + -> BotM (Int, Int) + processResult (oks_, errs_) eithRes_ = case eithRes_ of + Left err_ -> logAll err_ >> pure (oks_, errs_ + 1) + Right ok_ -> let oks_' = if ok_ then oks_ + 1 else oks_ in pure (oks_', errs_) + (oks, errs) <- foldM processResult (0, 0) eithRes + logInfo [int||#{oks} ephemeral sent successfully|] + logInfo [int||#{errs} ephemerals failed|] diff --git a/src/TzBot/Render.hs b/src/TzBot/Render.hs index f6f1d0e..6f395bb 100644 --- a/src/TzBot/Render.hs +++ b/src/TzBot/Render.hs @@ -128,7 +128,7 @@ renderSlackBlocks forSender = let t = (Mrkdwn $ tuTimeRef timeRef, Mrkdwn $ tuTranslation timeRef) mbNote = chooseNote forSender timeRef translationBlock = BSection $ fieldsSection Nothing $ NE.singleton t - mkNoteBlock note = BSection $ markdownSection (Mrkdwn note) + mkNoteBlock note = BSection $ markdownSection $ Mrkdwn note withMaybe mbNote [translationBlock] $ \note -> [translationBlock, mkNoteBlock note] renderTemplate :: UTCTime -> User -> NE.NonEmpty TimeReference -> Template diff --git a/src/TzBot/RunMonad.hs b/src/TzBot/RunMonad.hs index 6ccf366..a07f657 100644 --- a/src/TzBot/RunMonad.hs +++ b/src/TzBot/RunMonad.hs @@ -10,7 +10,6 @@ import Control.Lens (makeLensesWith) import Control.Monad.Base (MonadBase) import Control.Monad.Except (MonadError) import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Map qualified as M import Data.Set qualified as S import Katip qualified as K import Network.HTTP.Client (Manager) @@ -33,12 +32,11 @@ data BotState = BotState { bsConfig :: BotConfig , bsManager :: Manager , bsFeedbackConfig :: FeedbackConfig - -- TODO: after #22 bsMessagesReferences should either disappear or become - -- cached (not IORef). - , bsMessagesReferences :: IORef (M.Map MessageId (S.Set TimeReferenceText)) , bsUserInfoCache :: TzCache UserId User , bsConversationMembersCache :: TzCache ChannelId (S.Set UserId) , bsReportEntries :: TzCache ReportDialogId ReportDialogEntry + , bsMessageCache :: TzCache MessageId [TimeReference] + , bsMessageLinkCache :: TzCache MessageId Text , bsLogNamespace :: K.Namespace , bsLogContext :: K.LogContexts , bsLogEnv :: K.LogEnv diff --git a/src/TzBot/Slack.hs b/src/TzBot/Slack.hs index 57824b1..8aab798 100644 --- a/src/TzBot/Slack.hs +++ b/src/TzBot/Slack.hs @@ -19,6 +19,7 @@ module TzBot.Slack , startModal , updateModal , retrieveOneMessageFromThread + , getMessagePermalinkCached ) where import Universum hiding (toString) @@ -62,7 +63,7 @@ getUserCached :: UserId -> BotM User getUserCached userId = katipAddNamespaceText "getUser" $ do cache <- asks bsUserInfoCache - Cache.fetchWithCacheRandomized userId getUser cache + Cache.fetchWithCache userId getUser cache -- | Get a list of a channel's members. getChannelMembers :: ChannelId -> BotM (S.Set UserId) @@ -77,7 +78,7 @@ getChannelMembersCached :: ChannelId -> BotM (S.Set UserId) getChannelMembersCached channelId = katipAddNamespaceText "getChannelMembers" $ do cache <- asks bsConversationMembersCache - Cache.fetchWithCacheRandomized channelId getChannelMembers cache + Cache.fetchWithCache channelId getChannelMembers cache -- | Post an "ephemeral message", a message only visible to the given user. sendEphemeralMessage :: PostEphemeralReq -> BotM () @@ -156,6 +157,14 @@ updateModal req = do token <- getBotToken void $ updateView token req >>= handleSlackErrorSingle "views.update" +getMessagePermalinkCached :: ChannelId -> MessageId -> BotM Text +getMessagePermalinkCached channelId msgId = + asks bsMessageLinkCache >>= + Cache.fetchWithCache msgId \msgId' -> do + token <- getBotToken + resp <- getPermalink token channelId msgId' + handleSlackErrorSingle "chat.getPermalink" resp + getBotToken :: BotM Auth.Token getBotToken = do BotToken bt <- asks $ cBotToken . bsConfig @@ -222,6 +231,11 @@ openView :: Auth.Token -> OpenViewReq -> BotM (SlackResponse $ SlackContents "view" Value) updateView :: Auth.Token -> UpdateViewReq -> BotM (SlackResponse $ SlackContents "view" Value) +getPermalink + :: Auth.Token + -> ChannelId + -> MessageId + -> BotM (SlackResponse (SlackContents "permalink" Text)) usersInfo :<|> conversationMembers @@ -230,7 +244,8 @@ usersInfo :<|> conversationHistory :<|> conversationReplies :<|> openView - :<|> updateView = + :<|> updateView + :<|> getPermalink = hoistClient api naturalTransformation (client api) where baseUrl = BaseUrl Https "slack.com" 443 "api" diff --git a/src/TzBot/Slack/API.hs b/src/TzBot/Slack/API.hs index f22f3ed..f82a5eb 100644 --- a/src/TzBot/Slack/API.hs +++ b/src/TzBot/Slack/API.hs @@ -117,6 +117,12 @@ type API = :> "views.update" :> ReqBody '[JSON] UpdateViewReq :> Post '[JSON] (SlackResponse $ SlackContents "view" Value) + :<|> + Auth '[JWT] Text + :> "chat.getPermalink" + :> RequiredParam "channel" ChannelId + :> RequiredParam "message_ts" MessageId + :> Get '[JSON] (SlackResponse $ SlackContents "permalink" Text) api :: Proxy API api = Proxy @@ -192,7 +198,7 @@ newtype ThreadId = ThreadId { unThreadId :: Text } newtype MessageId = MessageId { unMessageId :: Text } deriving stock (Eq, Show, Ord) - deriving newtype (ToHttpApiData, FromJSON, ToJSON, Buildable) + deriving newtype (ToHttpApiData, FromJSON, ToJSON, Buildable, Hashable) newtype Limit = Limit { limitQ :: Int} deriving stock (Eq, Show) diff --git a/src/TzBot/Util.hs b/src/TzBot/Util.hs index 2cc560f..eb36de0 100644 --- a/src/TzBot/Util.hs +++ b/src/TzBot/Util.hs @@ -192,3 +192,6 @@ catchAllErrors action = fmap reorder $ try $ tryError action reorder (Left e) = Left (Left e) reorder (Right (Left e)) = Left (Right e) reorder (Right (Right r)) = Right r + +whenT :: (Applicative m) => Bool -> m Bool -> m Bool +whenT cond_ action_ = if cond_ then action_ else pure False