{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}

module Wire.API.Federation.BackendNotifications where

import Control.Exception
import Control.Monad.Codensity
import Control.Monad.Except
import Data.Aeson qualified as A
import Data.Domain
import Data.Id (RequestId)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Lazy.Encoding qualified as TL
import Imports
import Network.AMQP qualified as Q
import Network.AMQP.Types qualified as Q
import Servant
import Servant.Client.Core
import Wire.API.Federation.API.Common
import Wire.API.Federation.Client
import Wire.API.Federation.Component
import Wire.API.Federation.Error
import Wire.API.Federation.HasNotificationEndpoint
import Wire.API.Federation.Version
import Wire.API.RawJson

-- | NOTE: Stored in RabbitMQ, any changes to serialization of this object could cause
-- notifications to get lost.
data BackendNotification = BackendNotification
  { BackendNotification -> Domain
ownDomain :: Domain,
    BackendNotification -> Component
targetComponent :: Component,
    BackendNotification -> Text
path :: Text,
    -- | Using RawJson here allows the backend notification pusher to not parse
    -- this body, which could be very large and completely useless to the
    -- pusher. This also makes development less clunky as we don't have to
    -- create a sum type here for all types of notifications that could exist.
    BackendNotification -> RawJson
body :: RawJson,
    -- | The federation API versions that the 'body' corresponds to. The field
    -- is optional so that messages already in the queue are not lost.
    BackendNotification -> Maybe VersionRange
bodyVersions :: Maybe VersionRange,
    BackendNotification -> Maybe RequestId
requestId :: Maybe RequestId
  }
  deriving (Int -> BackendNotification -> ShowS
[BackendNotification] -> ShowS
BackendNotification -> String
(Int -> BackendNotification -> ShowS)
-> (BackendNotification -> String)
-> ([BackendNotification] -> ShowS)
-> Show BackendNotification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BackendNotification -> ShowS
showsPrec :: Int -> BackendNotification -> ShowS
$cshow :: BackendNotification -> String
show :: BackendNotification -> String
$cshowList :: [BackendNotification] -> ShowS
showList :: [BackendNotification] -> ShowS
Show, BackendNotification -> BackendNotification -> Bool
(BackendNotification -> BackendNotification -> Bool)
-> (BackendNotification -> BackendNotification -> Bool)
-> Eq BackendNotification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BackendNotification -> BackendNotification -> Bool
== :: BackendNotification -> BackendNotification -> Bool
$c/= :: BackendNotification -> BackendNotification -> Bool
/= :: BackendNotification -> BackendNotification -> Bool
Eq)
  deriving ([BackendNotification] -> Value
[BackendNotification] -> Encoding
BackendNotification -> Value
BackendNotification -> Encoding
(BackendNotification -> Value)
-> (BackendNotification -> Encoding)
-> ([BackendNotification] -> Value)
-> ([BackendNotification] -> Encoding)
-> ToJSON BackendNotification
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: BackendNotification -> Value
toJSON :: BackendNotification -> Value
$ctoEncoding :: BackendNotification -> Encoding
toEncoding :: BackendNotification -> Encoding
$ctoJSONList :: [BackendNotification] -> Value
toJSONList :: [BackendNotification] -> Value
$ctoEncodingList :: [BackendNotification] -> Encoding
toEncodingList :: [BackendNotification] -> Encoding
A.ToJSON, Value -> Parser [BackendNotification]
Value -> Parser BackendNotification
(Value -> Parser BackendNotification)
-> (Value -> Parser [BackendNotification])
-> FromJSON BackendNotification
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser BackendNotification
parseJSON :: Value -> Parser BackendNotification
$cparseJSONList :: Value -> Parser [BackendNotification]
parseJSONList :: Value -> Parser [BackendNotification]
A.FromJSON) via (Schema BackendNotification)

instance ToSchema BackendNotification where
  schema :: ValueSchema NamedSwaggerDoc BackendNotification
schema =
    Text
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification BackendNotification
-> ValueSchema NamedSwaggerDoc BackendNotification
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"BackendNotification" (SchemaP
   SwaggerDoc Object [Pair] BackendNotification BackendNotification
 -> ValueSchema NamedSwaggerDoc BackendNotification)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification BackendNotification
-> ValueSchema NamedSwaggerDoc BackendNotification
forall a b. (a -> b) -> a -> b
$
      Domain
-> Component
-> Text
-> RawJson
-> Maybe VersionRange
-> Maybe RequestId
-> BackendNotification
BackendNotification
        (Domain
 -> Component
 -> Text
 -> RawJson
 -> Maybe VersionRange
 -> Maybe RequestId
 -> BackendNotification)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Domain
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     BackendNotification
     (Component
      -> Text
      -> RawJson
      -> Maybe VersionRange
      -> Maybe RequestId
      -> BackendNotification)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BackendNotification -> Domain
ownDomain (BackendNotification -> Domain)
-> SchemaP SwaggerDoc Object [Pair] Domain Domain
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Domain
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Domain Domain
-> SchemaP SwaggerDoc Object [Pair] Domain Domain
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"ownDomain" SchemaP NamedSwaggerDoc Value Value Domain Domain
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  BackendNotification
  (Component
   -> Text
   -> RawJson
   -> Maybe VersionRange
   -> Maybe RequestId
   -> BackendNotification)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Component
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     BackendNotification
     (Text
      -> RawJson
      -> Maybe VersionRange
      -> Maybe RequestId
      -> BackendNotification)
forall a b.
SchemaP SwaggerDoc Object [Pair] BackendNotification (a -> b)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification a
-> SchemaP SwaggerDoc Object [Pair] BackendNotification b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BackendNotification -> Component
targetComponent (BackendNotification -> Component)
-> SchemaP SwaggerDoc Object [Pair] Component Component
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Component
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Component Component
-> SchemaP SwaggerDoc Object [Pair] Component Component
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"targetComponent" SchemaP NamedSwaggerDoc Value Value Component Component
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  BackendNotification
  (Text
   -> RawJson
   -> Maybe VersionRange
   -> Maybe RequestId
   -> BackendNotification)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Text
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     BackendNotification
     (RawJson
      -> Maybe VersionRange -> Maybe RequestId -> BackendNotification)
forall a b.
SchemaP SwaggerDoc Object [Pair] BackendNotification (a -> b)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification a
-> SchemaP SwaggerDoc Object [Pair] BackendNotification b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BackendNotification -> Text
path (BackendNotification -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text Text
-> SchemaP SwaggerDoc Object [Pair] BackendNotification Text
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP SwaggerDoc Object [Pair] Text Text
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"path" SchemaP NamedSwaggerDoc Value Value Text Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  BackendNotification
  (RawJson
   -> Maybe VersionRange -> Maybe RequestId -> BackendNotification)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification RawJson
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     BackendNotification
     (Maybe VersionRange -> Maybe RequestId -> BackendNotification)
forall a b.
SchemaP SwaggerDoc Object [Pair] BackendNotification (a -> b)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification a
-> SchemaP SwaggerDoc Object [Pair] BackendNotification b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> Text
TL.decodeUtf8 (ByteString -> Text)
-> (BackendNotification -> ByteString)
-> BackendNotification
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawJson -> ByteString
rawJsonBytes (RawJson -> ByteString)
-> (BackendNotification -> RawJson)
-> BackendNotification
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackendNotification -> RawJson
body)
          (BackendNotification -> Text)
-> SchemaP SwaggerDoc Object [Pair] Text RawJson
-> SchemaP SwaggerDoc Object [Pair] BackendNotification RawJson
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Text RawJson
-> SchemaP SwaggerDoc Object [Pair] Text RawJson
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"body" (ByteString -> RawJson
RawJson (ByteString -> RawJson) -> (Text -> ByteString) -> Text -> RawJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TL.encodeUtf8 (Text -> RawJson)
-> SchemaP NamedSwaggerDoc Value Value Text Text
-> SchemaP NamedSwaggerDoc Value Value Text RawJson
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaP NamedSwaggerDoc Value Value Text Text
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  BackendNotification
  (Maybe VersionRange -> Maybe RequestId -> BackendNotification)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification (Maybe VersionRange)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     BackendNotification
     (Maybe RequestId -> BackendNotification)
forall a b.
SchemaP SwaggerDoc Object [Pair] BackendNotification (a -> b)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification a
-> SchemaP SwaggerDoc Object [Pair] BackendNotification b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BackendNotification -> Maybe VersionRange
bodyVersions (BackendNotification -> Maybe VersionRange)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe VersionRange) (Maybe VersionRange)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification (Maybe VersionRange)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] VersionRange (Maybe VersionRange)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe VersionRange) (Maybe VersionRange)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP NamedSwaggerDoc Value Value VersionRange VersionRange
-> SchemaP
     SwaggerDoc Object [Pair] VersionRange (Maybe VersionRange)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"bodyVersions" SchemaP NamedSwaggerDoc Value Value VersionRange VersionRange
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  BackendNotification
  (Maybe RequestId -> BackendNotification)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification (Maybe RequestId)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification BackendNotification
forall a b.
SchemaP SwaggerDoc Object [Pair] BackendNotification (a -> b)
-> SchemaP SwaggerDoc Object [Pair] BackendNotification a
-> SchemaP SwaggerDoc Object [Pair] BackendNotification b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (.requestId) (BackendNotification -> Maybe RequestId)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe RequestId) (Maybe RequestId)
-> SchemaP
     SwaggerDoc Object [Pair] BackendNotification (Maybe RequestId)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] RequestId (Maybe RequestId)
-> SchemaP
     SwaggerDoc Object [Pair] (Maybe RequestId) (Maybe RequestId)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP NamedSwaggerDoc Value Value RequestId RequestId
-> SchemaP SwaggerDoc Object [Pair] RequestId (Maybe RequestId)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"requestId" SchemaP NamedSwaggerDoc Value Value RequestId RequestId
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)

-- | Convert a federation endpoint to a backend notification to be enqueued to a
-- RabbitMQ queue.
fedNotifToBackendNotif ::
  forall {k} (tag :: k).
  ( HasFedPath tag,
    HasVersionRange tag,
    KnownComponent (NotificationComponent k),
    A.ToJSON (Payload tag)
  ) =>
  RequestId ->
  Domain ->
  Payload tag ->
  BackendNotification
fedNotifToBackendNotif :: forall {k} (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId -> Domain -> Payload tag -> BackendNotification
fedNotifToBackendNotif RequestId
rid Domain
ownDomain Payload tag
payload =
  let p :: Text
p = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall (t :: k). HasFedPath t => String
forall {k} (t :: k). HasFedPath t => String
fedPath @tag
      b :: RawJson
b = ByteString -> RawJson
RawJson (ByteString -> RawJson)
-> (Payload tag -> ByteString) -> Payload tag -> RawJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload tag -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Payload tag -> RawJson) -> Payload tag -> RawJson
forall a b. (a -> b) -> a -> b
$ Payload tag
payload
   in Text -> RawJson -> BackendNotification
toNotif Text
p RawJson
b
  where
    toNotif :: Text -> RawJson -> BackendNotification
    toNotif :: Text -> RawJson -> BackendNotification
toNotif Text
path RawJson
body =
      BackendNotification
        { $sel:ownDomain:BackendNotification :: Domain
ownDomain = Domain
ownDomain,
          $sel:targetComponent:BackendNotification :: Component
targetComponent = forall (c :: Component). KnownComponent c => Component
componentVal @(NotificationComponent k),
          $sel:path:BackendNotification :: Text
path = Text
path,
          $sel:body:BackendNotification :: RawJson
body = RawJson
body,
          $sel:bodyVersions:BackendNotification :: Maybe VersionRange
bodyVersions = VersionRange -> Maybe VersionRange
forall a. a -> Maybe a
Just (VersionRange -> Maybe VersionRange)
-> VersionRange -> Maybe VersionRange
forall a b. (a -> b) -> a -> b
$ forall (t :: k). HasVersionRange t => VersionRange
forall {k} (t :: k). HasVersionRange t => VersionRange
versionRange @tag,
          $sel:requestId:BackendNotification :: Maybe RequestId
requestId = RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
rid
        }

newtype PayloadBundle (c :: Component) = PayloadBundle
  { forall (c :: Component).
PayloadBundle c -> NonEmpty BackendNotification
notifications :: NE.NonEmpty BackendNotification
  }
  deriving ([PayloadBundle c] -> Value
[PayloadBundle c] -> Encoding
PayloadBundle c -> Value
PayloadBundle c -> Encoding
(PayloadBundle c -> Value)
-> (PayloadBundle c -> Encoding)
-> ([PayloadBundle c] -> Value)
-> ([PayloadBundle c] -> Encoding)
-> ToJSON (PayloadBundle c)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall (c :: Component). [PayloadBundle c] -> Value
forall (c :: Component). [PayloadBundle c] -> Encoding
forall (c :: Component). PayloadBundle c -> Value
forall (c :: Component). PayloadBundle c -> Encoding
$ctoJSON :: forall (c :: Component). PayloadBundle c -> Value
toJSON :: PayloadBundle c -> Value
$ctoEncoding :: forall (c :: Component). PayloadBundle c -> Encoding
toEncoding :: PayloadBundle c -> Encoding
$ctoJSONList :: forall (c :: Component). [PayloadBundle c] -> Value
toJSONList :: [PayloadBundle c] -> Value
$ctoEncodingList :: forall (c :: Component). [PayloadBundle c] -> Encoding
toEncodingList :: [PayloadBundle c] -> Encoding
A.ToJSON, Value -> Parser [PayloadBundle c]
Value -> Parser (PayloadBundle c)
(Value -> Parser (PayloadBundle c))
-> (Value -> Parser [PayloadBundle c])
-> FromJSON (PayloadBundle c)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall (c :: Component). Value -> Parser [PayloadBundle c]
forall (c :: Component). Value -> Parser (PayloadBundle c)
$cparseJSON :: forall (c :: Component). Value -> Parser (PayloadBundle c)
parseJSON :: Value -> Parser (PayloadBundle c)
$cparseJSONList :: forall (c :: Component). Value -> Parser [PayloadBundle c]
parseJSONList :: Value -> Parser [PayloadBundle c]
A.FromJSON) via (Schema (PayloadBundle c))
  deriving newtype (NonEmpty (PayloadBundle c) -> PayloadBundle c
PayloadBundle c -> PayloadBundle c -> PayloadBundle c
(PayloadBundle c -> PayloadBundle c -> PayloadBundle c)
-> (NonEmpty (PayloadBundle c) -> PayloadBundle c)
-> (forall b.
    Integral b =>
    b -> PayloadBundle c -> PayloadBundle c)
-> Semigroup (PayloadBundle c)
forall b. Integral b => b -> PayloadBundle c -> PayloadBundle c
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (c :: Component).
NonEmpty (PayloadBundle c) -> PayloadBundle c
forall (c :: Component).
PayloadBundle c -> PayloadBundle c -> PayloadBundle c
forall (c :: Component) b.
Integral b =>
b -> PayloadBundle c -> PayloadBundle c
$c<> :: forall (c :: Component).
PayloadBundle c -> PayloadBundle c -> PayloadBundle c
<> :: PayloadBundle c -> PayloadBundle c -> PayloadBundle c
$csconcat :: forall (c :: Component).
NonEmpty (PayloadBundle c) -> PayloadBundle c
sconcat :: NonEmpty (PayloadBundle c) -> PayloadBundle c
$cstimes :: forall (c :: Component) b.
Integral b =>
b -> PayloadBundle c -> PayloadBundle c
stimes :: forall b. Integral b => b -> PayloadBundle c -> PayloadBundle c
Semigroup)

instance ToSchema (PayloadBundle c) where
  schema :: ValueSchema NamedSwaggerDoc (PayloadBundle c)
schema =
    Text
-> SchemaP
     SwaggerDoc Object [Pair] (PayloadBundle c) (PayloadBundle c)
-> ValueSchema NamedSwaggerDoc (PayloadBundle c)
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"PayloadBundle" (SchemaP
   SwaggerDoc Object [Pair] (PayloadBundle c) (PayloadBundle c)
 -> ValueSchema NamedSwaggerDoc (PayloadBundle c))
-> SchemaP
     SwaggerDoc Object [Pair] (PayloadBundle c) (PayloadBundle c)
-> ValueSchema NamedSwaggerDoc (PayloadBundle c)
forall a b. (a -> b) -> a -> b
$
      NonEmpty BackendNotification -> PayloadBundle c
forall (c :: Component).
NonEmpty BackendNotification -> PayloadBundle c
PayloadBundle
        (NonEmpty BackendNotification -> PayloadBundle c)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (PayloadBundle c)
     (NonEmpty BackendNotification)
-> SchemaP
     SwaggerDoc Object [Pair] (PayloadBundle c) (PayloadBundle c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PayloadBundle c -> NonEmpty BackendNotification
forall (c :: Component).
PayloadBundle c -> NonEmpty BackendNotification
notifications (PayloadBundle c -> NonEmpty BackendNotification)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (NonEmpty BackendNotification)
     (NonEmpty BackendNotification)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (PayloadBundle c)
     (NonEmpty BackendNotification)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP
     SwaggerDoc
     Value
     Value
     (NonEmpty BackendNotification)
     (NonEmpty BackendNotification)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (NonEmpty BackendNotification)
     (NonEmpty BackendNotification)
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"notifications" (ValueSchema NamedSwaggerDoc BackendNotification
-> SchemaP
     SwaggerDoc
     Value
     Value
     (NonEmpty BackendNotification)
     (NonEmpty BackendNotification)
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc,
 HasMinItems doc (Maybe Integer)) =>
ValueSchema ndoc a -> ValueSchema doc (NonEmpty a)
nonEmptyArray ValueSchema NamedSwaggerDoc BackendNotification
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)

toBundle ::
  forall {k} (tag :: k).
  ( HasFedPath tag,
    HasVersionRange tag,
    KnownComponent (NotificationComponent k),
    A.ToJSON (Payload tag)
  ) =>
  RequestId ->
  -- | The origin domain
  Domain ->
  Payload tag ->
  PayloadBundle (NotificationComponent k)
toBundle :: forall {k} (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId
-> Domain -> Payload tag -> PayloadBundle (NotificationComponent k)
toBundle RequestId
reqId Domain
originDomain Payload tag
payload =
  let notif :: BackendNotification
notif = forall (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId -> Domain -> Payload tag -> BackendNotification
forall {k} (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId -> Domain -> Payload tag -> BackendNotification
fedNotifToBackendNotif @tag RequestId
reqId Domain
originDomain Payload tag
payload
   in NonEmpty BackendNotification
-> PayloadBundle (NotificationComponent k)
forall (c :: Component).
NonEmpty BackendNotification -> PayloadBundle c
PayloadBundle (NonEmpty BackendNotification
 -> PayloadBundle (NotificationComponent k))
-> (BackendNotification -> NonEmpty BackendNotification)
-> BackendNotification
-> PayloadBundle (NotificationComponent k)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackendNotification -> NonEmpty BackendNotification
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BackendNotification -> PayloadBundle (NotificationComponent k))
-> BackendNotification -> PayloadBundle (NotificationComponent k)
forall a b. (a -> b) -> a -> b
$ BackendNotification
notif

makeBundle ::
  forall {k} (tag :: k) c.
  ( HasFedPath tag,
    HasVersionRange tag,
    KnownComponent (NotificationComponent k),
    A.ToJSON (Payload tag),
    c ~ NotificationComponent k
  ) =>
  Payload tag ->
  FedQueueClient c (PayloadBundle c)
makeBundle :: forall {k} (tag :: k) (c :: Component).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag),
 c ~ NotificationComponent k) =>
Payload tag -> FedQueueClient c (PayloadBundle c)
makeBundle Payload tag
payload = do
  RequestId
reqId <- (FedQueueEnv -> RequestId) -> FedQueueClient c RequestId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.requestId)
  Domain
origin <- (FedQueueEnv -> Domain) -> FedQueueClient c Domain
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.originDomain)
  PayloadBundle c -> FedQueueClient c (PayloadBundle c)
forall a. a -> FedQueueClient c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PayloadBundle c -> FedQueueClient c (PayloadBundle c))
-> PayloadBundle c -> FedQueueClient c (PayloadBundle c)
forall a b. (a -> b) -> a -> b
$ forall (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId
-> Domain -> Payload tag -> PayloadBundle (NotificationComponent k)
forall {k} (tag :: k).
(HasFedPath tag, HasVersionRange tag,
 KnownComponent (NotificationComponent k), ToJSON (Payload tag)) =>
RequestId
-> Domain -> Payload tag -> PayloadBundle (NotificationComponent k)
toBundle @tag RequestId
reqId Domain
origin Payload tag
payload

type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse

sendNotification :: FederatorClientVersionedEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ())
sendNotification :: FederatorClientVersionedEnv
-> Component
-> Text
-> RawJson
-> IO (Either FederatorClientError ())
sendNotification FederatorClientVersionedEnv
env Component
component Text
path RawJson
body = case Component -> SomeComponent
someComponent Component
component of
  SomeComponent Proxy c
p -> Proxy c -> IO (Either FederatorClientError ())
forall (c :: Component).
KnownComponent c =>
Proxy c -> IO (Either FederatorClientError ())
go Proxy c
p
  where
    withoutFirstSlash :: Text -> Text
    withoutFirstSlash :: Text -> Text
withoutFirstSlash (Text -> Text -> Maybe Text
Text.stripPrefix Text
"/" -> Just Text
t) = Text
t
    withoutFirstSlash Text
t = Text
t

    go :: forall c. (KnownComponent c) => Proxy c -> IO (Either FederatorClientError ())
    go :: forall (c :: Component).
KnownComponent c =>
Proxy c -> IO (Either FederatorClientError ())
go Proxy c
_ =
      Codensity IO (Either FederatorClientError ())
-> IO (Either FederatorClientError ())
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity
        (Codensity IO (Either FederatorClientError ())
 -> IO (Either FederatorClientError ()))
-> (FederatorClient c EmptyResponse
    -> Codensity IO (Either FederatorClientError ()))
-> FederatorClient c EmptyResponse
-> IO (Either FederatorClientError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT FederatorClientError (Codensity IO) ()
-> Codensity IO (Either FederatorClientError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT FederatorClientError (Codensity IO) ()
 -> Codensity IO (Either FederatorClientError ()))
-> (FederatorClient c EmptyResponse
    -> ExceptT FederatorClientError (Codensity IO) ())
-> FederatorClient c EmptyResponse
-> Codensity IO (Either FederatorClientError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientVersionedEnv
-> FederatorClient c ()
-> ExceptT FederatorClientError (Codensity IO) ()
forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity FederatorClientVersionedEnv
env
        (FederatorClient c ()
 -> ExceptT FederatorClientError (Codensity IO) ())
-> (FederatorClient c EmptyResponse -> FederatorClient c ())
-> FederatorClient c EmptyResponse
-> ExceptT FederatorClientError (Codensity IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClient c EmptyResponse -> FederatorClient c ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (FederatorClient c EmptyResponse
 -> IO (Either FederatorClientError ()))
-> FederatorClient c EmptyResponse
-> IO (Either FederatorClientError ())
forall a b. (a -> b) -> a -> b
$ Proxy BackendNotificationAPI
-> Proxy (FederatorClient c)
-> Client (FederatorClient c) BackendNotificationAPI
forall (m :: * -> *) api.
HasClient m api =>
Proxy api -> Proxy m -> Client m api
clientIn (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @BackendNotificationAPI) (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(FederatorClient c)) (Text -> Text
withoutFirstSlash Text
path) RawJson
body

enqueue :: Q.Channel -> RequestId -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a
enqueue :: forall {k} (c :: k) a.
Channel
-> RequestId
-> Domain
-> Domain
-> DeliveryMode
-> FedQueueClient c a
-> IO a
enqueue Channel
channel RequestId
requestId Domain
originDomain Domain
targetDomain DeliveryMode
deliveryMode (FedQueueClient ReaderT FedQueueEnv IO a
action) =
  ReaderT FedQueueEnv IO a -> FedQueueEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT FedQueueEnv IO a
action FedQueueEnv {Channel
DeliveryMode
RequestId
Domain
channel :: Channel
requestId :: RequestId
originDomain :: Domain
targetDomain :: Domain
deliveryMode :: DeliveryMode
$sel:channel:FedQueueEnv :: Channel
$sel:originDomain:FedQueueEnv :: Domain
$sel:targetDomain:FedQueueEnv :: Domain
$sel:deliveryMode:FedQueueEnv :: DeliveryMode
$sel:requestId:FedQueueEnv :: RequestId
..}

routingKey :: Text -> Text
routingKey :: Text -> Text
routingKey Text
t = Text
"backend-notifications." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t

-- Shared values for both brig and background worker so they are
-- kept in sync about what types they are expecting and where
-- they are stored in Rabbit.
type DefederationDomain = Domain

-- | If you ever change this function and modify
-- queue parameters, know that it will start failing in the
-- next release! So be prepared to write migrations.
ensureQueue :: Q.Channel -> Text -> IO ()
ensureQueue :: Channel -> Text -> IO ()
ensureQueue Channel
chan Text
queue = do
  let opts :: QueueOpts
opts =
        Q.QueueOpts
          { queueName :: Text
Q.queueName = Text -> Text
routingKey Text
queue,
            queuePassive :: Bool
Q.queuePassive = Bool
False,
            queueDurable :: Bool
Q.queueDurable = Bool
True,
            queueExclusive :: Bool
Q.queueExclusive = Bool
False,
            queueAutoDelete :: Bool
Q.queueAutoDelete = Bool
False,
            queueHeaders :: FieldTable
Q.queueHeaders =
              Map Text FieldValue -> FieldTable
Q.FieldTable (Map Text FieldValue -> FieldTable)
-> Map Text FieldValue -> FieldTable
forall a b. (a -> b) -> a -> b
$
                [(Text, FieldValue)] -> Map Text FieldValue
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  -- single-active-consumer is used because it is order
                  -- preserving, especially into databases and to remote servers,
                  -- exactly what we are doing here!
                  -- Without single active consumer, messages will be delivered
                  -- round-robbin to all consumers, but then we lose effect-ordering
                  -- due to processing and network times.
                  [ (Text
"x-single-active-consumer", Bool -> FieldValue
Q.FVBool Bool
True),
                    (Text
"x-queue-type", ByteString -> FieldValue
Q.FVString ByteString
"quorum")
                  ]
          }
  IO (Text, Int, Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Text, Int, Int) -> IO ()) -> IO (Text, Int, Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Channel -> QueueOpts -> IO (Text, Int, Int)
Q.declareQueue Channel
chan QueueOpts
opts

-- * Internal machinery

-- | Reads a servant request and puts the information in relevant RabbitMQ
-- queue. Perhaps none of this should be servant code anymore. But it is here to
-- allow smooth transition to RabbitMQ based notification pushing.
--
-- Use 'Wire.API.Federation.API.fedQueueClient' to create an action and pass it
-- to 'enqueue'
newtype FedQueueClient c a = FedQueueClient (ReaderT FedQueueEnv IO a)
  deriving ((forall a b. (a -> b) -> FedQueueClient c a -> FedQueueClient c b)
-> (forall a b. a -> FedQueueClient c b -> FedQueueClient c a)
-> Functor (FedQueueClient c)
forall k (c :: k) a b.
a -> FedQueueClient c b -> FedQueueClient c a
forall k (c :: k) a b.
(a -> b) -> FedQueueClient c a -> FedQueueClient c b
forall a b. a -> FedQueueClient c b -> FedQueueClient c a
forall a b. (a -> b) -> FedQueueClient c a -> FedQueueClient c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (c :: k) a b.
(a -> b) -> FedQueueClient c a -> FedQueueClient c b
fmap :: forall a b. (a -> b) -> FedQueueClient c a -> FedQueueClient c b
$c<$ :: forall k (c :: k) a b.
a -> FedQueueClient c b -> FedQueueClient c a
<$ :: forall a b. a -> FedQueueClient c b -> FedQueueClient c a
Functor, Functor (FedQueueClient c)
Functor (FedQueueClient c) =>
(forall a. a -> FedQueueClient c a)
-> (forall a b.
    FedQueueClient c (a -> b)
    -> FedQueueClient c a -> FedQueueClient c b)
-> (forall a b c.
    (a -> b -> c)
    -> FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c c)
-> (forall a b.
    FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b)
-> (forall a b.
    FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c a)
-> Applicative (FedQueueClient c)
forall a. a -> FedQueueClient c a
forall k (c :: k). Functor (FedQueueClient c)
forall k (c :: k) a. a -> FedQueueClient c a
forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c a
forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
forall k (c :: k) a b.
FedQueueClient c (a -> b)
-> FedQueueClient c a -> FedQueueClient c b
forall k (c :: k) a b c.
(a -> b -> c)
-> FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c c
forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c a
forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
forall a b.
FedQueueClient c (a -> b)
-> FedQueueClient c a -> FedQueueClient c b
forall a b c.
(a -> b -> c)
-> FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall k (c :: k) a. a -> FedQueueClient c a
pure :: forall a. a -> FedQueueClient c a
$c<*> :: forall k (c :: k) a b.
FedQueueClient c (a -> b)
-> FedQueueClient c a -> FedQueueClient c b
<*> :: forall a b.
FedQueueClient c (a -> b)
-> FedQueueClient c a -> FedQueueClient c b
$cliftA2 :: forall k (c :: k) a b c.
(a -> b -> c)
-> FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c c
liftA2 :: forall a b c.
(a -> b -> c)
-> FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c c
$c*> :: forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
*> :: forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
$c<* :: forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c a
<* :: forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c a
Applicative, Applicative (FedQueueClient c)
Applicative (FedQueueClient c) =>
(forall a b.
 FedQueueClient c a
 -> (a -> FedQueueClient c b) -> FedQueueClient c b)
-> (forall a b.
    FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b)
-> (forall a. a -> FedQueueClient c a)
-> Monad (FedQueueClient c)
forall a. a -> FedQueueClient c a
forall k (c :: k). Applicative (FedQueueClient c)
forall k (c :: k) a. a -> FedQueueClient c a
forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
forall k (c :: k) a b.
FedQueueClient c a
-> (a -> FedQueueClient c b) -> FedQueueClient c b
forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
forall a b.
FedQueueClient c a
-> (a -> FedQueueClient c b) -> FedQueueClient c b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall k (c :: k) a b.
FedQueueClient c a
-> (a -> FedQueueClient c b) -> FedQueueClient c b
>>= :: forall a b.
FedQueueClient c a
-> (a -> FedQueueClient c b) -> FedQueueClient c b
$c>> :: forall k (c :: k) a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
>> :: forall a b.
FedQueueClient c a -> FedQueueClient c b -> FedQueueClient c b
$creturn :: forall k (c :: k) a. a -> FedQueueClient c a
return :: forall a. a -> FedQueueClient c a
Monad, Monad (FedQueueClient c)
Monad (FedQueueClient c) =>
(forall a. IO a -> FedQueueClient c a)
-> MonadIO (FedQueueClient c)
forall a. IO a -> FedQueueClient c a
forall k (c :: k). Monad (FedQueueClient c)
forall k (c :: k) a. IO a -> FedQueueClient c a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall k (c :: k) a. IO a -> FedQueueClient c a
liftIO :: forall a. IO a -> FedQueueClient c a
MonadIO, MonadReader FedQueueEnv)

data FedQueueEnv = FedQueueEnv
  { FedQueueEnv -> Channel
channel :: Q.Channel,
    FedQueueEnv -> Domain
originDomain :: Domain,
    FedQueueEnv -> Domain
targetDomain :: Domain,
    FedQueueEnv -> DeliveryMode
deliveryMode :: Q.DeliveryMode,
    FedQueueEnv -> RequestId
requestId :: RequestId
  }

data EnqueueError = EnqueueError String
  deriving (Int -> EnqueueError -> ShowS
[EnqueueError] -> ShowS
EnqueueError -> String
(Int -> EnqueueError -> ShowS)
-> (EnqueueError -> String)
-> ([EnqueueError] -> ShowS)
-> Show EnqueueError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnqueueError -> ShowS
showsPrec :: Int -> EnqueueError -> ShowS
$cshow :: EnqueueError -> String
show :: EnqueueError -> String
$cshowList :: [EnqueueError] -> ShowS
showList :: [EnqueueError] -> ShowS
Show)

instance Exception EnqueueError