module Wire.API.FederationStatus
  ( FederationStatus (..),
    RemoteDomains (..),
  )
where

import Control.Applicative
import Control.Lens ((?~))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
import Data.Aeson qualified as A
import Data.Aeson.Types qualified as A
import Data.Domain
import Data.OpenApi qualified as S
import Data.Qualified
import Data.Schema
import Data.Set qualified as Set
import Imports
import Wire.Arbitrary

newtype RemoteDomains = RemoteDomains
  { RemoteDomains -> Set (Remote ())
rdDomains :: Set (Remote ())
  }
  deriving stock (RemoteDomains -> RemoteDomains -> Bool
(RemoteDomains -> RemoteDomains -> Bool)
-> (RemoteDomains -> RemoteDomains -> Bool) -> Eq RemoteDomains
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RemoteDomains -> RemoteDomains -> Bool
== :: RemoteDomains -> RemoteDomains -> Bool
$c/= :: RemoteDomains -> RemoteDomains -> Bool
/= :: RemoteDomains -> RemoteDomains -> Bool
Eq, Int -> RemoteDomains -> ShowS
[RemoteDomains] -> ShowS
RemoteDomains -> String
(Int -> RemoteDomains -> ShowS)
-> (RemoteDomains -> String)
-> ([RemoteDomains] -> ShowS)
-> Show RemoteDomains
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RemoteDomains -> ShowS
showsPrec :: Int -> RemoteDomains -> ShowS
$cshow :: RemoteDomains -> String
show :: RemoteDomains -> String
$cshowList :: [RemoteDomains] -> ShowS
showList :: [RemoteDomains] -> ShowS
Show, (forall x. RemoteDomains -> Rep RemoteDomains x)
-> (forall x. Rep RemoteDomains x -> RemoteDomains)
-> Generic RemoteDomains
forall x. Rep RemoteDomains x -> RemoteDomains
forall x. RemoteDomains -> Rep RemoteDomains x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RemoteDomains -> Rep RemoteDomains x
from :: forall x. RemoteDomains -> Rep RemoteDomains x
$cto :: forall x. Rep RemoteDomains x -> RemoteDomains
to :: forall x. Rep RemoteDomains x -> RemoteDomains
Generic)
  deriving (Gen RemoteDomains
Gen RemoteDomains
-> (RemoteDomains -> [RemoteDomains]) -> Arbitrary RemoteDomains
RemoteDomains -> [RemoteDomains]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen RemoteDomains
arbitrary :: Gen RemoteDomains
$cshrink :: RemoteDomains -> [RemoteDomains]
shrink :: RemoteDomains -> [RemoteDomains]
Arbitrary) via (GenericUniform RemoteDomains)
  deriving (Value -> Parser [RemoteDomains]
Value -> Parser RemoteDomains
(Value -> Parser RemoteDomains)
-> (Value -> Parser [RemoteDomains]) -> FromJSON RemoteDomains
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser RemoteDomains
parseJSON :: Value -> Parser RemoteDomains
$cparseJSONList :: Value -> Parser [RemoteDomains]
parseJSONList :: Value -> Parser [RemoteDomains]
FromJSON, [RemoteDomains] -> Value
[RemoteDomains] -> Encoding
RemoteDomains -> Value
RemoteDomains -> Encoding
(RemoteDomains -> Value)
-> (RemoteDomains -> Encoding)
-> ([RemoteDomains] -> Value)
-> ([RemoteDomains] -> Encoding)
-> ToJSON RemoteDomains
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: RemoteDomains -> Value
toJSON :: RemoteDomains -> Value
$ctoEncoding :: RemoteDomains -> Encoding
toEncoding :: RemoteDomains -> Encoding
$ctoJSONList :: [RemoteDomains] -> Value
toJSONList :: [RemoteDomains] -> Value
$ctoEncodingList :: [RemoteDomains] -> Encoding
toEncodingList :: [RemoteDomains] -> Encoding
ToJSON, Typeable RemoteDomains
Typeable RemoteDomains =>
(Proxy RemoteDomains -> Declare (Definitions Schema) NamedSchema)
-> ToSchema RemoteDomains
Proxy RemoteDomains -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy RemoteDomains -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy RemoteDomains -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema RemoteDomains

instance ToSchema RemoteDomains where
  schema :: ValueSchema NamedSwaggerDoc RemoteDomains
schema =
    Text
-> (NamedSwaggerDoc -> NamedSwaggerDoc)
-> ObjectSchema SwaggerDoc RemoteDomains
-> ValueSchema NamedSwaggerDoc RemoteDomains
forall doc doc' a.
HasObject doc doc' =>
Text -> (doc' -> doc') -> ObjectSchema doc a -> ValueSchema doc' a
objectWithDocModifier Text
"RemoteDomains" ((Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasDescription s a => Lens' s a
Lens' NamedSwaggerDoc (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Text -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"A set of remote domains") (ObjectSchema SwaggerDoc RemoteDomains
 -> ValueSchema NamedSwaggerDoc RemoteDomains)
-> ObjectSchema SwaggerDoc RemoteDomains
-> ValueSchema NamedSwaggerDoc RemoteDomains
forall a b. (a -> b) -> a -> b
$
      Set (Remote ()) -> RemoteDomains
RemoteDomains
        (Set (Remote ()) -> RemoteDomains)
-> SchemaP SwaggerDoc Object [Pair] RemoteDomains (Set (Remote ()))
-> ObjectSchema SwaggerDoc RemoteDomains
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Remote () -> Domain) -> Set (Remote ()) -> Set Domain
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Remote () -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain (Set (Remote ()) -> Set Domain)
-> (RemoteDomains -> Set (Remote ()))
-> RemoteDomains
-> Set Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteDomains -> Set (Remote ())
rdDomains)
          (RemoteDomains -> Set Domain)
-> SchemaP SwaggerDoc Object [Pair] (Set Domain) (Set (Remote ()))
-> SchemaP SwaggerDoc Object [Pair] RemoteDomains (Set (Remote ()))
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value (Set Domain) (Set (Remote ()))
-> SchemaP SwaggerDoc Object [Pair] (Set Domain) (Set (Remote ()))
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"domains" ((Domain -> Remote ()) -> Set Domain -> Set (Remote ())
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((Domain -> () -> Remote ()) -> () -> Domain -> Remote ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Domain -> () -> Remote ()
forall a. Domain -> a -> Remote a
toRemoteUnsafe ()) (Set Domain -> Set (Remote ()))
-> SchemaP SwaggerDoc Value Value (Set Domain) (Set Domain)
-> SchemaP SwaggerDoc Value Value (Set Domain) (Set (Remote ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueSchema NamedSwaggerDoc Domain
-> SchemaP SwaggerDoc Value Value (Set Domain) (Set Domain)
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc, Ord a) =>
ValueSchema ndoc a -> ValueSchema doc (Set a)
set ValueSchema NamedSwaggerDoc Domain
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)

-- | This value expresses if the requested remote domains are fully connected or not.
-- If not the response will contain the first pair of domains found
-- which do not federate with each other.
data FederationStatus
  = FullyConnected
  | NotConnectedDomains Domain Domain
  deriving stock (FederationStatus -> FederationStatus -> Bool
(FederationStatus -> FederationStatus -> Bool)
-> (FederationStatus -> FederationStatus -> Bool)
-> Eq FederationStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FederationStatus -> FederationStatus -> Bool
== :: FederationStatus -> FederationStatus -> Bool
$c/= :: FederationStatus -> FederationStatus -> Bool
/= :: FederationStatus -> FederationStatus -> Bool
Eq, Int -> FederationStatus -> ShowS
[FederationStatus] -> ShowS
FederationStatus -> String
(Int -> FederationStatus -> ShowS)
-> (FederationStatus -> String)
-> ([FederationStatus] -> ShowS)
-> Show FederationStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FederationStatus -> ShowS
showsPrec :: Int -> FederationStatus -> ShowS
$cshow :: FederationStatus -> String
show :: FederationStatus -> String
$cshowList :: [FederationStatus] -> ShowS
showList :: [FederationStatus] -> ShowS
Show, (forall x. FederationStatus -> Rep FederationStatus x)
-> (forall x. Rep FederationStatus x -> FederationStatus)
-> Generic FederationStatus
forall x. Rep FederationStatus x -> FederationStatus
forall x. FederationStatus -> Rep FederationStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FederationStatus -> Rep FederationStatus x
from :: forall x. FederationStatus -> Rep FederationStatus x
$cto :: forall x. Rep FederationStatus x -> FederationStatus
to :: forall x. Rep FederationStatus x -> FederationStatus
Generic)
  deriving (Gen FederationStatus
Gen FederationStatus
-> (FederationStatus -> [FederationStatus])
-> Arbitrary FederationStatus
FederationStatus -> [FederationStatus]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen FederationStatus
arbitrary :: Gen FederationStatus
$cshrink :: FederationStatus -> [FederationStatus]
shrink :: FederationStatus -> [FederationStatus]
Arbitrary) via (GenericUniform FederationStatus)
  deriving (Value -> Parser [FederationStatus]
Value -> Parser FederationStatus
(Value -> Parser FederationStatus)
-> (Value -> Parser [FederationStatus])
-> FromJSON FederationStatus
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser FederationStatus
parseJSON :: Value -> Parser FederationStatus
$cparseJSONList :: Value -> Parser [FederationStatus]
parseJSONList :: Value -> Parser [FederationStatus]
FromJSON, [FederationStatus] -> Value
[FederationStatus] -> Encoding
FederationStatus -> Value
FederationStatus -> Encoding
(FederationStatus -> Value)
-> (FederationStatus -> Encoding)
-> ([FederationStatus] -> Value)
-> ([FederationStatus] -> Encoding)
-> ToJSON FederationStatus
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: FederationStatus -> Value
toJSON :: FederationStatus -> Value
$ctoEncoding :: FederationStatus -> Encoding
toEncoding :: FederationStatus -> Encoding
$ctoJSONList :: [FederationStatus] -> Value
toJSONList :: [FederationStatus] -> Value
$ctoEncodingList :: [FederationStatus] -> Encoding
toEncodingList :: [FederationStatus] -> Encoding
ToJSON, Typeable FederationStatus
Typeable FederationStatus =>
(Proxy FederationStatus
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema FederationStatus
Proxy FederationStatus -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy FederationStatus -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy FederationStatus -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema FederationStatus

instance ToSchema FederationStatus where
  schema :: ValueSchema NamedSwaggerDoc FederationStatus
schema = NamedSwaggerDoc
-> (Value -> Parser FederationStatus)
-> (FederationStatus -> Maybe Value)
-> ValueSchema NamedSwaggerDoc FederationStatus
forall doc v b a w.
doc -> (v -> Parser b) -> (a -> Maybe w) -> SchemaP doc v w a b
mkSchema NamedSwaggerDoc
descr Value -> Parser FederationStatus
toFederationStatus FederationStatus -> Maybe Value
fromFederationStatus
    where
      toFederationStatus :: A.Value -> A.Parser FederationStatus
      toFederationStatus :: Value -> Parser FederationStatus
toFederationStatus = String
-> (Object -> Parser FederationStatus)
-> Value
-> Parser FederationStatus
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"FederationStatus" ((Object -> Parser FederationStatus)
 -> Value -> Parser FederationStatus)
-> (Object -> Parser FederationStatus)
-> Value
-> Parser FederationStatus
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        Text
status :: Text <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status"
        case Text
status of
          Text
"fully-connected" -> FederationStatus -> Parser FederationStatus
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FederationStatus
FullyConnected
          Text
"non-fully-connected" -> do
            [Domain]
domains <- Object
o Object -> Key -> Parser [Domain]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"not_connected"
            case [Domain]
domains of
              [Domain
a, Domain
b] -> FederationStatus -> Parser FederationStatus
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FederationStatus -> Parser FederationStatus)
-> FederationStatus -> Parser FederationStatus
forall a b. (a -> b) -> a -> b
$ Domain -> Domain -> FederationStatus
NotConnectedDomains Domain
a Domain
b
              [Domain]
_ -> String -> Parser FederationStatus
forall a. String -> Parser a
A.parseFail String
"Expected exactly two domains in field not_connected."
          Text
_ -> String -> Parser FederationStatus
forall a. String -> Parser a
A.parseFail String
"Expected field status to be 'fully-connected' or 'non-fully-connected'."

      fromFederationStatus :: FederationStatus -> Maybe A.Value
      fromFederationStatus :: FederationStatus -> Maybe Value
fromFederationStatus = \case
        FederationStatus
FullyConnected -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
A.object [Key
"status" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= (Text
"fully-connected" :: Text)]
        NotConnectedDomains Domain
a Domain
b -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
A.object [Key
"status" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= (Text
"non-fully-connected" :: Text), Key
"not_connected" Key -> [Domain] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
A..= [Domain
a, Domain
b]]

      descr :: NamedSwaggerDoc
      descr :: NamedSwaggerDoc
descr =
        forall a. ToSchema a => NamedSwaggerDoc
swaggerDoc @Text
          NamedSwaggerDoc
-> (NamedSwaggerDoc -> NamedSwaggerDoc) -> NamedSwaggerDoc
forall a b. a -> (a -> b) -> b
& (Schema -> Identity Schema)
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasSchema s a => Lens' s a
Lens' NamedSwaggerDoc Schema
S.schema ((Schema -> Identity Schema)
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> ((Maybe Text -> Identity (Maybe Text))
    -> Schema -> Identity Schema)
-> (Maybe Text -> Identity (Maybe Text))
-> NamedSwaggerDoc
-> Identity NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
S.description
            ((Maybe Text -> Identity (Maybe Text))
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Text -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"This value expresses if the requested remote domains are fully connected or not. \
               \If not, it contains exactly two remote domains which do not federate with each other."
          NamedSwaggerDoc
-> (NamedSwaggerDoc -> NamedSwaggerDoc) -> NamedSwaggerDoc
forall a b. a -> (a -> b) -> b
& (Schema -> Identity Schema)
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasSchema s a => Lens' s a
Lens' NamedSwaggerDoc Schema
S.schema ((Schema -> Identity Schema)
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Schema -> Identity Schema)
-> (Maybe Value -> Identity (Maybe Value))
-> NamedSwaggerDoc
-> Identity NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
Lens' Schema (Maybe Value)
S.example ((Maybe Value -> Identity (Maybe Value))
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Value -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
"{ \"status\": \"fully-connected\", \"not_connected\": [] }"
          NamedSwaggerDoc
-> (NamedSwaggerDoc -> NamedSwaggerDoc) -> NamedSwaggerDoc
forall a b. a -> (a -> b) -> b
& (Schema -> Identity Schema)
-> NamedSwaggerDoc -> Identity NamedSwaggerDoc
forall s a. HasSchema s a => Lens' s a
Lens' NamedSwaggerDoc Schema
S.schema ((Schema -> Identity Schema)
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Schema -> Identity Schema)
-> (Maybe Value -> Identity (Maybe Value))
-> NamedSwaggerDoc
-> Identity NamedSwaggerDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasExample s a => Lens' s a
Lens' Schema (Maybe Value)
S.example ((Maybe Value -> Identity (Maybe Value))
 -> NamedSwaggerDoc -> Identity NamedSwaggerDoc)
-> Value -> NamedSwaggerDoc -> NamedSwaggerDoc
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
"{ \"status\": \"non-fully-connected\", \"not_connected\": [\"d.example.com\", \"e.example.com\"] }"