{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}

module MatrixBot.Bot.Jobs.Handlers.SendReaction
  ( sendReaction
  ) where

import Data.Aeson (ToJSON (toJSON), FromJSON (parseJSON), decode)
import Data.Data (Proxy (Proxy))
import Data.Text (Text, pack)
import MatrixBot.AesonUtils (myGenericToJSON, myGenericParseJSON)
import MatrixBot.Bot.Jobs.Log (logEventResponse)
import qualified MatrixBot.Log as L
import qualified MatrixBot.MatrixApi as Api
import qualified MatrixBot.MatrixApi.Client as Api
import qualified MatrixBot.MatrixApi.Types.MEventTypes as Api
import qualified MatrixBot.SharedTypes as T
import Servant.API (AuthProtect)
import Servant.Client.Core (AuthenticatedRequest)
import qualified Servant.Client.Core as Servant
import qualified Network.HTTP.Types.Status as Http
import GHC.Generics (Generic)
import qualified Control.Exception.Safe as E
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO)
import qualified Control.Monad.Logger as ML


-- | Leave a reaction for a Matrix room event
sendReaction
  ∷ (MonadIO m, MonadFail m, E.MonadCatch m, ML.MonadLogger m)
  ⇒ Api.MatrixApiClient
  → AuthenticatedRequest (AuthProtect "access-token")
  → T.TransactionId
  → T.RoomId
  → T.EventId
  → Text
  → m (Maybe Api.EventResponse)
  -- ^ @Nothing@ in case of “same reaction twice error” (idempotency)
sendReaction :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadCatch m, MonadLogger m) =>
MatrixApiClient
-> AuthenticatedRequest (AuthProtect "access-token")
-> TransactionId
-> RoomId
-> EventId
-> Text
-> m (Maybe EventResponse)
sendReaction MatrixApiClient
req AuthenticatedRequest (AuthProtect "access-token")
auth TransactionId
transactionId RoomId
roomId EventId
eventId Text
reactionText = do
  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
"Sending reaction ", String -> Text
pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
reactionText
    , Text
" to room ", String -> Text
pack (String -> Text) -> (RoomId -> String) -> RoomId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (RoomId -> Text) -> RoomId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoomId -> Text
T.printRoomId (RoomId -> Text) -> RoomId -> Text
forall a b. (a -> b) -> a -> b
$ RoomId
roomId
    , Text
" for ", EventId -> Text
T.unEventId EventId
eventId
    , Text
"…"
    ]

  Maybe EventResponse
response ← do
    let proxy :: Proxy (SendEventApi (MEventTypeOneOf '[ 'MReactionType]))
proxy = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Api.SendEventApi (Api.MEventTypeOneOf '[ 'Api.MReactionType ])) in
      m EventResponse -> m (Maybe EventResponse)
forall (m :: * -> *) a.
(MonadCatch m, MonadLogger m) =>
m a -> m (Maybe a)
ignoreSendSameReactionTwiceError (m EventResponse -> m (Maybe EventResponse))
-> m EventResponse -> m (Maybe EventResponse)
forall a b. (a -> b) -> a -> b
$
        MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m a
Api.runMatrixApiClient' MatrixApiClient
req Proxy
  (ClientV3
     (Authenticated
        ("rooms"
         :> (Capture "roomId" RoomId
             :> ("send"
                 :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                     :> (Capture "txnId" TransactionId
                         :> (ReqBody '[JSON] MReactionContent
                             :> Put '[JSON] EventResponse))))))))
proxy ((forall {clientM :: * -> *}.
  HasClient
    clientM
    (ClientV3
       (Authenticated
          ("rooms"
           :> (Capture "roomId" RoomId
               :> ("send"
                   :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                       :> (Capture "txnId" TransactionId
                           :> (ReqBody '[JSON] MReactionContent
                               :> Put '[JSON] EventResponse)))))))) =>
  Client
    clientM
    (ClientV3
       (Authenticated
          ("rooms"
           :> (Capture "roomId" RoomId
               :> ("send"
                   :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                       :> (Capture "txnId" TransactionId
                           :> (ReqBody '[JSON] MReactionContent
                               :> Put '[JSON] EventResponse))))))))
  -> clientM EventResponse)
 -> m EventResponse)
-> (forall {clientM :: * -> *}.
    HasClient
      clientM
      (ClientV3
         (Authenticated
            ("rooms"
             :> (Capture "roomId" RoomId
                 :> ("send"
                     :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                         :> (Capture "txnId" TransactionId
                             :> (ReqBody '[JSON] MReactionContent
                                 :> Put '[JSON] EventResponse)))))))) =>
    Client
      clientM
      (ClientV3
         (Authenticated
            ("rooms"
             :> (Capture "roomId" RoomId
                 :> ("send"
                     :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                         :> (Capture "txnId" TransactionId
                             :> (ReqBody '[JSON] MReactionContent
                                 :> Put '[JSON] EventResponse))))))))
    -> clientM EventResponse)
-> m EventResponse
forall a b. (a -> b) -> a -> b
$ \Client
  clientM
  (ClientV3
     (Authenticated
        ("rooms"
         :> (Capture "roomId" RoomId
             :> ("send"
                 :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                     :> (Capture "txnId" TransactionId
                         :> (ReqBody '[JSON] MReactionContent
                             :> Put '[JSON] EventResponse))))))))
f → Client
  clientM
  (ClientV3
     (Authenticated
        ("rooms"
         :> (Capture "roomId" RoomId
             :> ("send"
                 :> (Capture "eventType" (MEventTypeOneOf '[ 'MReactionType])
                     :> (Capture "txnId" TransactionId
                         :> (ReqBody '[JSON] MReactionContent
                             :> Put '[JSON] EventResponse))))))))
AuthenticatedRequest (AuthProtect "access-token")
-> RoomId
-> MEventTypeOneOf '[ 'MReactionType]
-> TransactionId
-> MReactionContent
-> clientM EventResponse
f
          AuthenticatedRequest (AuthProtect "access-token")
auth
          RoomId
roomId
          MEventTypeOneOf '[ 'MReactionType]
forall (types :: [MEventType]).
(OneOf 'MReactionType types ~ 'True) =>
MEventTypeOneOf types
Api.MReactionTypeOneOf
          TransactionId
transactionId
          (RelatesTo -> MReactionContent
Api.MReactionContent (RelatesTo -> MReactionContent) -> RelatesTo -> MReactionContent
forall a b. (a -> b) -> a -> b
$ EventId
-> Text -> MEventTypeOneOf '[ 'MAnnotationType] -> RelatesTo
Api.RelatesTo EventId
eventId Text
reactionText MEventTypeOneOf '[ 'MAnnotationType]
forall (types :: [MEventType]).
(OneOf 'MAnnotationType types ~ 'True) =>
MEventTypeOneOf types
Api.MAnnotationTypeOneOf)

  Maybe EventResponse
response Maybe EventResponse -> m () -> m (Maybe EventResponse)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case Maybe EventResponse
response of
    Just EventResponse
x → EventResponse -> m ()
forall (m :: * -> *). MonadLogger m => EventResponse -> m ()
logEventResponse EventResponse
x
    Maybe EventResponse
Nothing → 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
"Reaction ", String -> Text
pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
reactionText
      , Text
" to room ", String -> Text
pack (String -> Text) -> (RoomId -> String) -> RoomId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (RoomId -> Text) -> RoomId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoomId -> Text
T.printRoomId (RoomId -> Text) -> RoomId -> Text
forall a b. (a -> b) -> a -> b
$ RoomId
roomId
      , Text
" for ", EventId -> Text
T.unEventId EventId
eventId
      , Text
" is already sent (considering this a success)"
      ]


-- | A helper to guarantee idempotency of applying a reaction.
--
-- If reaction is already present the error will be just ignored.
ignoreSendSameReactionTwiceError
  ∷ (E.MonadCatch m, ML.MonadLogger m)
  ⇒ m a
  → m (Maybe a)
  -- ^ @Nothing@ in case it’s “same reaction twice” ignored error
ignoreSendSameReactionTwiceError :: forall (m :: * -> *) a.
(MonadCatch m, MonadLogger m) =>
m a -> m (Maybe a)
ignoreSendSameReactionTwiceError =
  (m (Maybe a) -> (ClientError -> m (Maybe a)) -> m (Maybe a))
-> (ClientError -> m (Maybe a)) -> m (Maybe a) -> m (Maybe a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip m (Maybe a) -> (ClientError -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch ((Maybe a
forall a. Maybe a
Nothing Maybe a -> m () -> m (Maybe a)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (m () -> m (Maybe a))
-> (ClientError -> m ()) -> ClientError -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadLogger m) =>
ClientError -> m ()
resolveClientError) (m (Maybe a) -> m (Maybe a))
-> (m a -> m (Maybe a)) -> m a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> m a -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
  where
    logCaughtException ∷ (Show e, ML.MonadLogger m) ⇒ e → m ()
    logCaughtException :: forall e (m :: * -> *). (Show e, MonadLogger m) => e -> m ()
logCaughtException e
e =
      Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
L.logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Caught this error (just ignoring it): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (e -> String) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) e
e

    resolveClientError ∷ (E.MonadThrow m, ML.MonadLogger m) ⇒ Servant.ClientError → m ()
    resolveClientError :: forall (m :: * -> *).
(MonadThrow m, MonadLogger m) =>
ClientError -> m ()
resolveClientError ClientError
e =
      m () -> (ErrorResponse -> m ()) -> Maybe ErrorResponse -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ClientError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
E.throwM ClientError
e) ErrorResponse -> m ()
forall e (m :: * -> *). (Show e, MonadLogger m) => e -> m ()
logCaughtException (Maybe ErrorResponse -> m ()) -> Maybe ErrorResponse -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Response
response ← case ClientError
e of
          Servant.FailureResponse RequestF () (BaseUrl, ByteString)
_req Response
response → Response -> Maybe Response
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
response
          ClientError
_ → Maybe Response
forall a. Maybe a
Nothing
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Status -> Int
Http.statusCode (Status -> Int) -> (Response -> Status) -> Response -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Status
forall a. ResponseF a -> Status
Servant.responseStatusCode) Response
response Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
400
        ErrorResponse
x ← forall a. FromJSON a => ByteString -> Maybe a
decode @ErrorResponse (ByteString -> Maybe ErrorResponse)
-> (Response -> ByteString) -> Response -> Maybe ErrorResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> ByteString
forall a. ResponseF a -> a
Servant.responseBody (Response -> Maybe ErrorResponse)
-> Response -> Maybe ErrorResponse
forall a b. (a -> b) -> a -> b
$ Response
response
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ErrorResponse -> Text
errorResponseErrcode ErrorResponse
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"M_UNKNOWN"
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ErrorResponse -> Text
errorResponseError ErrorResponse
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Can't send same reaction twice"
        ErrorResponse -> Maybe ErrorResponse
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorResponse
x


data ErrorResponse = ErrorResponse
  { ErrorResponse -> Text
errorResponseErrcode ∷ Text
  , ErrorResponse -> Text
errorResponseError ∷ Text
  }
  deriving stock ((forall x. ErrorResponse -> Rep ErrorResponse x)
-> (forall x. Rep ErrorResponse x -> ErrorResponse)
-> Generic ErrorResponse
forall x. Rep ErrorResponse x -> ErrorResponse
forall x. ErrorResponse -> Rep ErrorResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ErrorResponse -> Rep ErrorResponse x
from :: forall x. ErrorResponse -> Rep ErrorResponse x
$cto :: forall x. Rep ErrorResponse x -> ErrorResponse
to :: forall x. Rep ErrorResponse x -> ErrorResponse
Generic, Int -> ErrorResponse -> ShowS
[ErrorResponse] -> ShowS
ErrorResponse -> String
(Int -> ErrorResponse -> ShowS)
-> (ErrorResponse -> String)
-> ([ErrorResponse] -> ShowS)
-> Show ErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorResponse -> ShowS
showsPrec :: Int -> ErrorResponse -> ShowS
$cshow :: ErrorResponse -> String
show :: ErrorResponse -> String
$cshowList :: [ErrorResponse] -> ShowS
showList :: [ErrorResponse] -> ShowS
Show, ErrorResponse -> ErrorResponse -> Bool
(ErrorResponse -> ErrorResponse -> Bool)
-> (ErrorResponse -> ErrorResponse -> Bool) -> Eq ErrorResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorResponse -> ErrorResponse -> Bool
== :: ErrorResponse -> ErrorResponse -> Bool
$c/= :: ErrorResponse -> ErrorResponse -> Bool
/= :: ErrorResponse -> ErrorResponse -> Bool
Eq)

instance ToJSON ErrorResponse where toJSON :: ErrorResponse -> Value
toJSON = ErrorResponse -> Value
forall a.
(Generic a, Typeable a, GToJSON' Value Zero (Rep a)) =>
a -> Value
myGenericToJSON
instance FromJSON ErrorResponse where parseJSON :: Value -> Parser ErrorResponse
parseJSON = Value -> Parser ErrorResponse
forall a.
(Generic a, Typeable a, GFromJSON Zero (Rep a)) =>
Value -> Parser a
myGenericParseJSON