{-# 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
data BackendNotification = BackendNotification
{ BackendNotification -> Domain
ownDomain :: Domain,
BackendNotification -> Component
targetComponent :: Component,
BackendNotification -> Text
path :: Text,
BackendNotification -> RawJson
body :: RawJson,
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)
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 ->
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
type DefederationDomain = Domain
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
[ (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
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