{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module MatrixBot.Bot.EventsListener.Handlers.ReactToUsers
  ( reactToUsers
  ) where

import qualified Control.Lens as Lens
import Control.Monad (forM_)
import Control.Monad.Trans (lift)
import qualified Control.Monad.Trans.Except as Except
import qualified Data.List.NonEmpty as NE
import Data.Text (pack)
import MatrixBot.Bot.BotConfig (BotConfigReactToUsers (..))
import MatrixBot.Bot.BotM (BotM)
import MatrixBot.Bot.Jobs.BotJob (BotJob (BotJobSendReaction))
import qualified MatrixBot.Log as L
import qualified MatrixBot.SharedTypes as T
import qualified UnliftIO.STM as STM
import MatrixBot.Bot.Jobs.Queue (HasBotJobsWriter (botJobsWriter))
import qualified MatrixBot.Bot.EventsListener.Filters as Filters


-- | Process @m.room.message@ event and see if there is a need to leave a reaction for it.
reactToUsers
  ∷ (BotM r m, HasBotJobsWriter r)
  ⇒ [BotConfigReactToUsers]
  -- ^ Bot configuration for “react to users” feature
  → T.RoomId
  -- ^ Matrix room where there event was sent to
  → T.Mxid
  -- ^ User ID (who sent the event)
  → T.EventId
  -- ^ Unique identifier of the event
  → m ()
reactToUsers :: forall r (m :: * -> *).
(BotM r m, HasBotJobsWriter r) =>
[BotConfigReactToUsers] -> RoomId -> Mxid -> EventId -> m ()
reactToUsers [] RoomId
_ Mxid
_ EventId
_ =
  Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Text
"There is no configuration entries for “react to users” feature. "
    , Text
"No reactions will be left for the event."
    ]
reactToUsers [BotConfigReactToUsers]
configEntries RoomId
roomId Mxid
userId EventId
eventId = do
  Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug Text
"Going through “react to users” configuration to see if this event is matching…"
  (BotConfigReactToUsers -> m ()) -> [BotConfigReactToUsers] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BotConfigReactToUsers -> m ()
handleEntry [BotConfigReactToUsers]
configEntries

  where
    resolveFilter :: Either Text () -> m ()
resolveFilter =
      ((Text -> m ()) -> (() -> m ()) -> Either Text () -> m ())
-> (() -> m ()) -> (Text -> m ()) -> Either Text () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> m ()) -> (() -> m ()) -> Either Text () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text -> m ()) -> Either Text () -> m ())
-> (Text -> m ()) -> Either Text () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Event mismatched filter (skipping this reaction config entry): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

    handleEntry :: BotConfigReactToUsers -> m ()
handleEntry BotConfigReactToUsers
entry = (Either Text () -> m ()
resolveFilter (Either Text () -> m ()) -> m (Either Text ()) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m (Either Text ()) -> m ()) -> m (Either Text ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ExceptT Text m () -> m (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Text m () -> m (Either Text ()))
-> ExceptT Text m () -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
      Text -> ExceptT Text m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> ExceptT Text m ()) -> Text -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Text
"Handling reaction config entry: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text)
-> (BotConfigReactToUsers -> String)
-> BotConfigReactToUsers
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BotConfigReactToUsers -> String
forall a. Show a => a -> String
show) BotConfigReactToUsers
entry

      Maybe UsersFilter -> Mxid -> ExceptT Text m ()
forall (m :: * -> *).
MonadLogger m =>
Maybe UsersFilter -> Mxid -> ExceptT Text m ()
Filters.filterByUser (BotConfigReactToUsers -> Maybe UsersFilter
botConfigReactToUsersUsersFilter BotConfigReactToUsers
entry) Mxid
userId
      Maybe RoomsFilter -> RoomId -> ExceptT Text m ()
forall (m :: * -> *).
MonadLogger m =>
Maybe RoomsFilter -> RoomId -> ExceptT Text m ()
Filters.filterByRoom (BotConfigReactToUsers -> Maybe RoomsFilter
botConfigReactToUsersRoomsFilter BotConfigReactToUsers
entry) RoomId
roomId

      let reactions :: NonEmpty Text
reactions = BotConfigReactToUsers -> NonEmpty Text
botConfigReactToUsersLeaveReactions BotConfigReactToUsers
entry

      Text -> ExceptT Text m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logDebug (Text -> ExceptT Text m ()) -> Text -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Leaving ", (String -> Text
pack (String -> Text)
-> (NonEmpty Text -> String) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> String
forall a. Show a => a -> String
show ([Text] -> String)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList) NonEmpty Text
reactions
        , Text
" reactions for event ", EventId -> Text
T.unEventId EventId
eventId
        , Text
" in room ", RoomId -> Text
T.printRoomId RoomId
roomId
        , Text
"…"
        ]

      m () -> ExceptT Text m ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Text m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT Text m ())
-> ((Text -> m ()) -> m ()) -> (Text -> m ()) -> ExceptT Text m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty Text
reactions ((Text -> m ()) -> ExceptT Text m ())
-> (Text -> m ()) -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ \Text
reactionText → do
        TransactionId
transactionId ← m TransactionId
forall (m :: * -> *). MonadIO m => m TransactionId
T.genTransactionId
        Getting (BotJob -> STM ()) r (BotJob -> STM ())
-> m (BotJob -> STM ())
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
Lens.view Getting (BotJob -> STM ()) r (BotJob -> STM ())
forall r. HasBotJobsWriter r => Getter r (BotJob -> STM ())
Getter r (BotJob -> STM ())
botJobsWriter m (BotJob -> STM ()) -> ((BotJob -> STM ()) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BotJob -> STM ()
sendJob →
          STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
STM.atomically (STM () -> m ()) -> (BotJob -> STM ()) -> BotJob -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BotJob -> STM ()
sendJob (BotJob -> m ()) -> BotJob -> m ()
forall a b. (a -> b) -> a -> b
$
            TransactionId -> RoomId -> EventId -> Text -> BotJob
BotJobSendReaction TransactionId
transactionId RoomId
roomId EventId
eventId Text
reactionText