-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Wire.API.Error.Galley
  ( GalleyError (..),
    OperationDenied,
    MLSProtocolError,
    mlsProtocolError,
    AuthenticationError (..),
    TeamFeatureError (..),
    MLSProposalFailure (..),
    NonFederatingBackends (..),
    UnreachableBackends (..),
    unreachableUsersToUnreachableBackends,
    UnreachableBackendsLegacy (..),
  )
where

import Control.Lens ((%~), (.~), (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Containers.ListUtils
import Data.Domain
import Data.HashMap.Strict.InsOrd (singleton)
import Data.OpenApi qualified as S
import Data.Proxy
import Data.Qualified
import Data.Schema
import Data.Singletons.TH (genSingletons)
import Data.Tagged
import GHC.TypeLits
import Imports
import Network.HTTP.Types.Status qualified as HTTP
import Network.Wai.Utilities.Error qualified as Wai
import Network.Wai.Utilities.JSONResponse
import Polysemy
import Polysemy.Error
import Prelude.Singletons (Show_)
import Servant.API.ContentTypes (JSON, contentType)
import Wire.API.Conversation.Role
import Wire.API.Error
import Wire.API.Error.Brig qualified as BrigError
import Wire.API.Routes.API
import Wire.API.Team.HardTruncationLimit
import Wire.API.Team.Permission
import Wire.API.Unreachable
import Wire.API.Util.Aeson (CustomEncoded (..))

data GalleyError
  = InvalidAction
  | InvalidTargetAccess
  | TeamNotFound
  | TeamMemberNotFound
  | NotATeamMember
  | NonBindingTeam
  | BroadcastLimitExceeded
  | UserBindingExists
  | NoAddToBinding
  | TooManyTeamMembers
  | TooManyTeamAdmins
  | -- FUTUREWORK: possibly make MissingPermission take a list of Perm
    MissingPermission (Maybe Perm)
  | ActionDenied Action
  | NotConnected
  | InvalidOperation
  | InvalidTarget
  | ConvNotFound
  | ConvAccessDenied
  | ConvInvalidProtocolTransition
  | -- MLS Errors
    MLSNotEnabled
  | MLSNonEmptyMemberList
  | MLSDuplicatePublicKey
  | MLSInvalidLeafNodeIndex
  | MLSUnsupportedMessage
  | MLSProposalNotFound
  | MLSUnsupportedProposal
  | MLSProtocolErrorTag
  | MLSClientMismatch
  | MLSStaleMessage
  | MLSCommitMissingReferences
  | MLSSelfRemovalNotAllowed
  | MLSGroupConversationMismatch
  | MLSClientSenderUserMismatch
  | MLSWelcomeMismatch
  | MLSMissingGroupInfo
  | MLSUnexpectedSenderClient
  | MLSSubConvUnsupportedConvType
  | MLSSubConvClientNotInParent
  | MLSMigrationCriteriaNotSatisfied
  | MLSFederatedOne2OneNotSupported
  | -- | MLS and federation are incompatible with legalhold - this error is thrown if a user
    -- tries to create an MLS group while being under legalhold
    MLSLegalholdIncompatible
  | --
    NoBindingTeamMembers
  | NoBindingTeam
  | NotAOneMemberTeam
  | TooManyMembers
  | ConvMemberNotFound
  | GuestLinksDisabled
  | CodeNotFound
  | InvalidConversationPassword
  | CreateConversationCodeConflict
  | InvalidPermissions
  | InvalidTeamStatusUpdate
  | AccessDenied
  | CustomBackendNotFound
  | DeleteQueueFull
  | TeamSearchVisibilityNotEnabled
  | CannotEnableLegalHoldServiceLargeTeam
  | -- Legal hold Error
    -- FUTUREWORK: make LegalHoldError more static and documented
    MissingLegalholdConsent
  | MissingLegalholdConsentOldClients
  | NoUserLegalHoldConsent
  | LegalHoldNotEnabled
  | LegalHoldDisableUnimplemented
  | LegalHoldServiceInvalidKey
  | LegalHoldServiceBadResponse
  | UserLegalHoldAlreadyEnabled
  | LegalHoldServiceNotRegistered
  | LegalHoldCouldNotBlockConnections
  | UserLegalHoldIllegalOperation
  | TooManyTeamMembersOnTeamWithLegalhold
  | NoLegalHoldDeviceAllocated
  | UserLegalHoldNotPending
  | -- Team Member errors
    BulkGetMemberLimitExceeded
  | -- Team Notification errors
    InvalidTeamNotificationId
  deriving (Int -> GalleyError -> ShowS
[GalleyError] -> ShowS
GalleyError -> String
(Int -> GalleyError -> ShowS)
-> (GalleyError -> String)
-> ([GalleyError] -> ShowS)
-> Show GalleyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GalleyError -> ShowS
showsPrec :: Int -> GalleyError -> ShowS
$cshow :: GalleyError -> String
show :: GalleyError -> String
$cshowList :: [GalleyError] -> ShowS
showList :: [GalleyError] -> ShowS
Show, GalleyError -> GalleyError -> Bool
(GalleyError -> GalleyError -> Bool)
-> (GalleyError -> GalleyError -> Bool) -> Eq GalleyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GalleyError -> GalleyError -> Bool
== :: GalleyError -> GalleyError -> Bool
$c/= :: GalleyError -> GalleyError -> Bool
/= :: GalleyError -> GalleyError -> Bool
Eq, (forall x. GalleyError -> Rep GalleyError x)
-> (forall x. Rep GalleyError x -> GalleyError)
-> Generic GalleyError
forall x. Rep GalleyError x -> GalleyError
forall x. GalleyError -> Rep GalleyError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GalleyError -> Rep GalleyError x
from :: forall x. GalleyError -> Rep GalleyError x
$cto :: forall x. Rep GalleyError x -> GalleyError
to :: forall x. Rep GalleyError x -> GalleyError
Generic)
  deriving (Value -> Parser [GalleyError]
Value -> Parser GalleyError
(Value -> Parser GalleyError)
-> (Value -> Parser [GalleyError]) -> FromJSON GalleyError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser GalleyError
parseJSON :: Value -> Parser GalleyError
$cparseJSONList :: Value -> Parser [GalleyError]
parseJSONList :: Value -> Parser [GalleyError]
FromJSON, [GalleyError] -> Value
[GalleyError] -> Encoding
GalleyError -> Value
GalleyError -> Encoding
(GalleyError -> Value)
-> (GalleyError -> Encoding)
-> ([GalleyError] -> Value)
-> ([GalleyError] -> Encoding)
-> ToJSON GalleyError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: GalleyError -> Value
toJSON :: GalleyError -> Value
$ctoEncoding :: GalleyError -> Encoding
toEncoding :: GalleyError -> Encoding
$ctoJSONList :: [GalleyError] -> Value
toJSONList :: [GalleyError] -> Value
$ctoEncodingList :: [GalleyError] -> Encoding
toEncodingList :: [GalleyError] -> Encoding
ToJSON) via (CustomEncoded GalleyError)

instance S.ToSchema GalleyError

$(genSingletons [''GalleyError])

instance (Typeable (MapError e), KnownError (MapError e)) => IsSwaggerError (e :: GalleyError) where
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi = forall (e :: StaticError).
(Typeable e, KnownError e) =>
OpenApi -> OpenApi
addStaticErrorToSwagger @(MapError e)

instance (KnownError (MapError e)) => APIError (Tagged (e :: GalleyError) ()) where
  toResponse :: Tagged e () -> JSONResponse
toResponse Tagged e ()
_ = DynError -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (DynError -> JSONResponse) -> DynError -> JSONResponse
forall a b. (a -> b) -> a -> b
$ forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e)

-- | Convenience synonym for an operation denied error with an unspecified permission.
type OperationDenied = 'MissingPermission 'Nothing

-- | An MLS protocol error with associated text.
type MLSProtocolError = Tagged 'MLSProtocolErrorTag Text

-- | Create an MLS protocol error value.
mlsProtocolError :: Text -> MLSProtocolError
mlsProtocolError :: Text -> MLSProtocolError
mlsProtocolError = Text -> MLSProtocolError
forall {k} (s :: k) b. b -> Tagged s b
Tagged

type family GalleyErrorEffect (e :: GalleyError) :: Effect where
  GalleyErrorEffect 'MLSProtocolErrorTag = Error MLSProtocolError
  GalleyErrorEffect e = ErrorS e

type instance ErrorEffect (e :: GalleyError) = GalleyErrorEffect e

type instance MapError 'InvalidAction = 'StaticError 400 "invalid-actions" "The specified actions are invalid"

type instance MapError 'InvalidTargetAccess = 'StaticError 403 "invalid-op" "Invalid target access"

type instance MapError 'TeamNotFound = 'StaticError 404 "no-team" "Team not found"

type instance MapError 'NonBindingTeam = 'StaticError 404 "non-binding-team" "Not a member of a binding team"

type instance MapError 'BroadcastLimitExceeded = 'StaticError 400 "too-many-users-to-broadcast" "Too many users to fan out the broadcast event to"

type instance MapError 'TeamMemberNotFound = 'StaticError 404 "no-team-member" "Team member not found"

type instance MapError 'NotATeamMember = 'StaticError 403 "no-team-member" "Requesting user is not a team member"

type instance MapError 'UserBindingExists = 'StaticError 403 "binding-exists" "User already bound to a different team"

type instance MapError 'NoAddToBinding = 'StaticError 403 "binding-team" "Cannot add users to binding teams, invite only"

type instance MapError 'TooManyTeamMembers = 'StaticError 403 "too-many-team-members" "Maximum number of members per team reached"

type instance MapError 'TooManyTeamAdmins = 'StaticError 403 "too-many-team-admins" "Maximum number of admins per team reached"

type instance MapError ('MissingPermission mperm) = 'StaticError 403 "operation-denied" (MissingPermissionMessage mperm)

type instance MapError ('ActionDenied action) = 'StaticError 403 "action-denied" ("Insufficient authorization (missing " `AppendSymbol` ActionName action `AppendSymbol` ")")

type instance MapError 'NotConnected = 'StaticError 403 "not-connected" "Users are not connected"

type instance MapError 'InvalidOperation = 'StaticError 403 "invalid-op" "Invalid operation"

type instance MapError 'InvalidTarget = 'StaticError 403 "invalid-op" "Invalid target"

type instance MapError 'ConvNotFound = 'StaticError 404 "no-conversation" "Conversation not found"

type instance MapError 'ConvAccessDenied = 'StaticError 403 "access-denied" "Conversation access denied"

type instance MapError 'ConvInvalidProtocolTransition = 'StaticError 403 "invalid-protocol-transition" "Protocol transition is invalid"

type instance MapError 'InvalidTeamNotificationId = 'StaticError 400 "invalid-notification-id" "Could not parse notification id (must be UUIDv1)."

type instance
  MapError 'MLSNotEnabled =
    'StaticError
      400
      "mls-not-enabled"
      "MLS is not configured on this backend. See docs.wire.com for instructions on how to enable it"

type instance MapError 'MLSNonEmptyMemberList = 'StaticError 400 "non-empty-member-list" "Attempting to add group members outside MLS"

type instance MapError 'MLSDuplicatePublicKey = 'StaticError 400 "mls-duplicate-public-key" "MLS public key for the given signature scheme already exists"

type instance MapError 'MLSInvalidLeafNodeIndex = 'StaticError 400 "mls-invalid-leaf-node-index" "A referenced leaf node index points to a blank or non-existing node"

type instance MapError 'MLSUnsupportedMessage = 'StaticError 422 "mls-unsupported-message" "Attempted to send a message with an unsupported combination of content type and wire format"

type instance MapError 'MLSProposalNotFound = 'StaticError 404 "mls-proposal-not-found" "A proposal referenced in a commit message could not be found"

type instance MapError 'MLSUnsupportedProposal = 'StaticError 422 "mls-unsupported-proposal" "Unsupported proposal type"

type instance MapError 'MLSProtocolErrorTag = MapError 'BrigError.MLSProtocolError

type instance MapError 'MLSClientMismatch = 'StaticError 409 "mls-client-mismatch" "A proposal of type Add or Remove does not apply to the full list of clients for a user"

type instance MapError 'MLSStaleMessage = 'StaticError 409 "mls-stale-message" "The conversation epoch in a message is too old"

type instance MapError 'MLSCommitMissingReferences = 'StaticError 400 "mls-commit-missing-references" "The commit is not referencing all pending proposals"

type instance MapError 'MLSSelfRemovalNotAllowed = 'StaticError 400 "mls-self-removal-not-allowed" "Self removal from group is not allowed"

type instance MapError 'MLSGroupConversationMismatch = 'StaticError 400 "mls-group-conversation-mismatch" "Conversation ID resolved from Group ID does not match submitted Conversation ID"

type instance MapError 'MLSClientSenderUserMismatch = 'StaticError 400 "mls-client-sender-user-mismatch" "User ID resolved from Client ID does not match message's sender user ID"

type instance MapError 'MLSWelcomeMismatch = 'StaticError 400 "mls-welcome-mismatch" "The list of targets of a welcome message does not match the list of new clients in a group"

type instance MapError 'MLSMissingGroupInfo = 'StaticError 404 "mls-missing-group-info" "The conversation has no group information"

type instance MapError 'MLSSubConvUnsupportedConvType = 'StaticError 403 "mls-subconv-unsupported-convtype" "MLS subconversations are only supported for regular conversations"

type instance MapError 'MLSSubConvClientNotInParent = 'StaticError 403 "mls-subconv-join-parent-missing" "MLS client cannot join the subconversation because it is not member of the parent conversation"

type instance MapError 'MLSMigrationCriteriaNotSatisfied = 'StaticError 400 "mls-migration-criteria-not-satisfied" "The migration criteria for mixed to MLS protocol transition are not satisfied for this conversation"

type instance MapError 'MLSFederatedOne2OneNotSupported = 'StaticError 400 "mls-federated-one2one-not-supported" "Federated One2One MLS conversations are only supported in API version >= 6"

type instance MapError MLSLegalholdIncompatible = 'StaticError 409 "mls-legal-hold-not-allowed" "A user who is under legal-hold may not participate in MLS conversations"

type instance MapError 'NoBindingTeamMembers = 'StaticError 403 "non-binding-team-members" "Both users must be members of the same binding team"

type instance MapError 'NoBindingTeam = 'StaticError 403 "no-binding-team" "Operation allowed only on binding teams"

type instance MapError 'NotAOneMemberTeam = 'StaticError 403 "not-one-member-team" "Can only delete teams with a single member"

type instance MapError 'TooManyMembers = 'StaticError 403 "too-many-members" "Maximum number of members per conversation reached"

type instance MapError 'ConvMemberNotFound = 'StaticError 404 "no-conversation-member" "Conversation member not found"

type instance MapError 'GuestLinksDisabled = 'StaticError 409 "guest-links-disabled" "The guest link feature is disabled and all guest links have been revoked"

type instance MapError 'CodeNotFound = 'StaticError 404 "no-conversation-code" "Conversation code not found"

type instance MapError 'InvalidConversationPassword = 'StaticError 403 "invalid-conversation-password" "Invalid conversation password"

type instance MapError 'CreateConversationCodeConflict = 'StaticError 409 "create-conv-code-conflict" "Conversation code already exists with a different password setting than the requested one."

type instance MapError 'InvalidPermissions = 'StaticError 403 "invalid-permissions" "The specified permissions are invalid"

type instance MapError 'InvalidTeamStatusUpdate = 'StaticError 403 "invalid-team-status-update" "Cannot use this endpoint to update the team to the given status."

type instance MapError 'AccessDenied = 'StaticError 403 "access-denied" "You do not have permission to access this resource"

type instance MapError 'CustomBackendNotFound = 'StaticError 404 "custom-backend-not-found" "Custom backend not found"

type instance MapError 'DeleteQueueFull = 'StaticError 503 "queue-full" "The delete queue is full; no further delete requests can be processed at the moment"

type instance MapError 'TeamSearchVisibilityNotEnabled = 'StaticError 403 "team-search-visibility-not-enabled" "Custom search is not available for this team"

type instance MapError 'CannotEnableLegalHoldServiceLargeTeam = 'StaticError 403 "too-large-team-for-legalhold" "Cannot enable legalhold on large teams (reason: for removing LH from team, we need to iterate over all members, which is only supported for teams with less than 2k members)"

-- We need this to document possible (operation denied) errors in the servant routes.
type family MissingPermissionMessage (a :: Maybe Perm) :: Symbol where
  MissingPermissionMessage ('Just p) = "Insufficient permissions (missing " `AppendSymbol` Show_ p `AppendSymbol` ")"
  MissingPermissionMessage 'Nothing = "Insufficient permissions"

--------------------------------------------------------------------------------
-- Legal hold Errors

type instance MapError 'TooManyTeamMembersOnTeamWithLegalhold = 'StaticError 403 "too-many-members-for-legalhold" "cannot add more members to team when legalhold service is enabled."

type instance MapError 'LegalHoldServiceInvalidKey = 'StaticError 400 "legalhold-invalid-key" "legal hold service pubkey is invalid"

type instance MapError 'MissingLegalholdConsent = 'StaticError 403 "missing-legalhold-consent" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has not granted consent"

type instance MapError 'MissingLegalholdConsentOldClients = 'StaticError 403 "missing-legalhold-consent-old-clients" "Failed to connect to a user or to invite a user to a group because somebody is under legalhold and somebody else has old clients that do not support legalhold's UI requirements"

type instance MapError 'LegalHoldServiceNotRegistered = 'StaticError 400 "legalhold-not-registered" "legal hold service has not been registered for this team"

type instance MapError 'LegalHoldServiceBadResponse = 'StaticError 400 "legalhold-status-bad" "legal hold service: invalid response"

type instance MapError 'LegalHoldNotEnabled = 'StaticError 403 "legalhold-not-enabled" "legal hold is not enabled for this team"

type instance MapError 'LegalHoldDisableUnimplemented = 'StaticError 403 "legalhold-disable-unimplemented" "legal hold cannot be disabled for whitelisted teams"

type instance MapError 'UserLegalHoldAlreadyEnabled = 'StaticError 409 "legalhold-already-enabled" "legal hold is already enabled for this user"

type instance MapError 'NoUserLegalHoldConsent = 'StaticError 409 "legalhold-no-consent" "user has not given consent to using legal hold"

type instance MapError 'UserLegalHoldIllegalOperation = 'StaticError 500 "legalhold-illegal-op" "internal server error: inconsistent change of user's legalhold state"

type instance MapError 'UserLegalHoldNotPending = 'StaticError 412 "legalhold-not-pending" "legal hold cannot be approved without being in a pending state"

type instance MapError 'NoLegalHoldDeviceAllocated = 'StaticError 404 "legalhold-no-device-allocated" "no legal hold device is registered for this user. POST /teams/:tid/legalhold/:uid/ to start the flow."

type instance MapError 'LegalHoldCouldNotBlockConnections = 'StaticError 500 "legalhold-internal" "legal hold service: could not block connections when resolving policy conflicts."

--------------------------------------------------------------------------------
-- Team Member errors

type instance MapError 'BulkGetMemberLimitExceeded = 'StaticError 400 "too-many-uids" ("Can only process " `AppendSymbol` Show_ HardTruncationLimit `AppendSymbol` " user ids per request.")

--------------------------------------------------------------------------------
-- Authentication errors

data AuthenticationError
  = ReAuthFailed
  | VerificationCodeAuthFailed
  | VerificationCodeRequired

type instance MapError 'ReAuthFailed = 'StaticError 403 "access-denied" "This operation requires reauthentication"

type instance MapError 'VerificationCodeAuthFailed = 'StaticError 403 "code-authentication-failed" "Code authentication failed"

type instance MapError 'VerificationCodeRequired = 'StaticError 403 "code-authentication-required" "Verification code required"

instance IsSwaggerError AuthenticationError where
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi =
    forall (e :: StaticError).
(Typeable e, KnownError e) =>
OpenApi -> OpenApi
addStaticErrorToSwagger @(MapError 'ReAuthFailed)
      (OpenApi -> OpenApi) -> (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e :: StaticError).
(Typeable e, KnownError e) =>
OpenApi -> OpenApi
addStaticErrorToSwagger @(MapError 'VerificationCodeAuthFailed)
      (OpenApi -> OpenApi) -> (OpenApi -> OpenApi) -> OpenApi -> OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e :: StaticError).
(Typeable e, KnownError e) =>
OpenApi -> OpenApi
addStaticErrorToSwagger @(MapError 'VerificationCodeRequired)

type instance ErrorEffect AuthenticationError = Error AuthenticationError

authenticationErrorToDyn :: AuthenticationError -> DynError
authenticationErrorToDyn :: AuthenticationError -> DynError
authenticationErrorToDyn AuthenticationError
ReAuthFailed = forall (e :: StaticError). KnownError e => DynError
dynError @(MapError 'ReAuthFailed)
authenticationErrorToDyn AuthenticationError
VerificationCodeAuthFailed = forall (e :: StaticError). KnownError e => DynError
dynError @(MapError 'VerificationCodeAuthFailed)
authenticationErrorToDyn AuthenticationError
VerificationCodeRequired = forall (e :: StaticError). KnownError e => DynError
dynError @(MapError 'VerificationCodeRequired)

instance (Member (Error DynError) r) => ServerEffect (Error AuthenticationError) r where
  interpretServerEffect :: forall a. Sem (Error AuthenticationError : r) a -> Sem r a
interpretServerEffect = (AuthenticationError -> DynError)
-> Sem (Error AuthenticationError : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError AuthenticationError -> DynError
authenticationErrorToDyn

--------------------------------------------------------------------------------
-- Team feature errors

data TeamFeatureError
  = AppLockInactivityTimeoutTooLow
  | LegalHoldFeatureFlagNotEnabled
  | LegalHoldWhitelistedOnly
  | DisableSsoNotImplemented
  | FeatureLocked
  | MLSProtocolMismatch
  | MLSE2EIDMissingCrlProxy
  | EmptyDownloadLocation

instance IsSwaggerError TeamFeatureError where
  -- Do not display in Swagger
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi = OpenApi -> OpenApi
forall a. a -> a
id

instance (Member (Error DynError) r) => ServerEffect (Error TeamFeatureError) r where
  interpretServerEffect :: forall a. Sem (Error TeamFeatureError : r) a -> Sem r a
interpretServerEffect = (TeamFeatureError -> DynError)
-> Sem (Error TeamFeatureError : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError ((TeamFeatureError -> DynError)
 -> Sem (Error TeamFeatureError : r) a -> Sem r a)
-> (TeamFeatureError -> DynError)
-> Sem (Error TeamFeatureError : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    TeamFeatureError
AppLockInactivityTimeoutTooLow ->
      Nat -> Text -> Text -> DynError
DynError
        Nat
400
        Text
"inactivity-timeout-too-low"
        Text
"Applock inactivity timeout must be at least 30 seconds"
    TeamFeatureError
LegalHoldFeatureFlagNotEnabled -> Nat -> Text -> Text -> DynError
DynError Nat
403 Text
"legalhold-not-enabled" Text
"Legal hold is not enabled for this wire instance"
    TeamFeatureError
LegalHoldWhitelistedOnly -> Nat -> Text -> Text -> DynError
DynError Nat
403 Text
"legalhold-whitelisted-only" Text
"Legal hold is enabled for teams via server config and cannot be changed here"
    TeamFeatureError
DisableSsoNotImplemented ->
      Nat -> Text -> Text -> DynError
DynError
        Nat
403
        Text
"not-implemented"
        Text
"The SSO feature flag is disabled by default.  It can only be enabled once for any team, never disabled.\n\
        \\n\
        \Rationale: there are two services in the backend that need to keep their status in sync: galley (teams),\n\
        \and spar (SSO).  Galley keeps track of team features.  If galley creates an idp, the feature flag is\n\
        \checked.  For authentication, spar avoids this expensive check and assumes that the idp can only have\n\
        \been created if the SSO is enabled.  This assumption does not hold any more if the switch is turned off\n\
        \again, so we do not support this.\n\
        \\n\
        \It is definitely feasible to change this.  If you have a use case, please contact customer support, or\n\
        \open an issue on https://github.com/wireapp/wire-server."
    TeamFeatureError
FeatureLocked -> Nat -> Text -> Text -> DynError
DynError Nat
409 Text
"feature-locked" Text
"Feature config cannot be updated (e.g. because it is configured to be locked, or because you need to upgrade your plan)"
    TeamFeatureError
MLSProtocolMismatch -> Nat -> Text -> Text -> DynError
DynError Nat
400 Text
"mls-protocol-mismatch" Text
"The default protocol needs to be part of the supported protocols"
    TeamFeatureError
MLSE2EIDMissingCrlProxy -> Nat -> Text -> Text -> DynError
DynError Nat
400 Text
"mls-e2eid-missing-crl-proxy" Text
"The field 'crlProxy' is missing in the request payload"
    TeamFeatureError
EmptyDownloadLocation -> Nat -> Text -> Text -> DynError
DynError Nat
400 Text
"empty-download-location" Text
"Download location cannot be empty"

type instance ErrorEffect TeamFeatureError = Error TeamFeatureError

--------------------------------------------------------------------------------
-- Proposal failure

data MLSProposalFailure = MLSProposalFailure
  { MLSProposalFailure -> JSONResponse
pfInner :: JSONResponse
  }

type instance ErrorEffect MLSProposalFailure = Error MLSProposalFailure

-- Proposal failures are only reported generically in Swagger
instance IsSwaggerError MLSProposalFailure where
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi = (Operation -> Identity Operation) -> OpenApi -> Identity OpenApi
Traversal' OpenApi Operation
S.allOperations ((Operation -> Identity Operation) -> OpenApi -> Identity OpenApi)
-> ((Maybe Text -> Identity (Maybe Text))
    -> Operation -> Identity Operation)
-> (Maybe Text -> Identity (Maybe Text))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation
forall s a. HasDescription s a => Lens' s a
Lens' Operation (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text))
 -> OpenApi -> Identity OpenApi)
-> (Maybe Text -> Maybe Text) -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (Maybe Text -> Text) -> Maybe Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc) (Text -> Text) -> (Maybe Text -> Text) -> Maybe Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    where
      desc :: Text
desc =
        Text
"\n\n**Note**: this endpoint can execute proposals, and therefore \
        \return all possible errors associated with adding or removing members to \
        \a conversation, in addition to the ones listed below. See the documentation of [POST \
        \/conversations/{cnv}/members/v2](#/default/post_conversations__cnv__members_v2) \
        \and [POST \
        \/conversations/{cnv_domain}/{cnv}/members/{usr_domain}/{usr}](#/default/delete_conversations__cnv_domain___cnv__members__usr_domain___usr_) \
        \for more details on the possible error responses of each type of \
        \proposal."

instance (Member (Error JSONResponse) r) => ServerEffect (Error MLSProposalFailure) r where
  interpretServerEffect :: forall a. Sem (Error MLSProposalFailure : r) a -> Sem r a
interpretServerEffect = (MLSProposalFailure -> JSONResponse)
-> Sem (Error MLSProposalFailure : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError MLSProposalFailure -> JSONResponse
pfInner

--------------------------------------------------------------------------------
-- Non-federating backends

-- | This is returned when adding members to the conversation is not possible
-- because the backends involved do not form a fully connected graph.
data NonFederatingBackends = NonFederatingBackends Domain Domain
  deriving stock (NonFederatingBackends -> NonFederatingBackends -> Bool
(NonFederatingBackends -> NonFederatingBackends -> Bool)
-> (NonFederatingBackends -> NonFederatingBackends -> Bool)
-> Eq NonFederatingBackends
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NonFederatingBackends -> NonFederatingBackends -> Bool
== :: NonFederatingBackends -> NonFederatingBackends -> Bool
$c/= :: NonFederatingBackends -> NonFederatingBackends -> Bool
/= :: NonFederatingBackends -> NonFederatingBackends -> Bool
Eq, Int -> NonFederatingBackends -> ShowS
[NonFederatingBackends] -> ShowS
NonFederatingBackends -> String
(Int -> NonFederatingBackends -> ShowS)
-> (NonFederatingBackends -> String)
-> ([NonFederatingBackends] -> ShowS)
-> Show NonFederatingBackends
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NonFederatingBackends -> ShowS
showsPrec :: Int -> NonFederatingBackends -> ShowS
$cshow :: NonFederatingBackends -> String
show :: NonFederatingBackends -> String
$cshowList :: [NonFederatingBackends] -> ShowS
showList :: [NonFederatingBackends] -> ShowS
Show, (forall x. NonFederatingBackends -> Rep NonFederatingBackends x)
-> (forall x. Rep NonFederatingBackends x -> NonFederatingBackends)
-> Generic NonFederatingBackends
forall x. Rep NonFederatingBackends x -> NonFederatingBackends
forall x. NonFederatingBackends -> Rep NonFederatingBackends x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NonFederatingBackends -> Rep NonFederatingBackends x
from :: forall x. NonFederatingBackends -> Rep NonFederatingBackends x
$cto :: forall x. Rep NonFederatingBackends x -> NonFederatingBackends
to :: forall x. Rep NonFederatingBackends x -> NonFederatingBackends
Generic)
  deriving (Value -> Parser [NonFederatingBackends]
Value -> Parser NonFederatingBackends
(Value -> Parser NonFederatingBackends)
-> (Value -> Parser [NonFederatingBackends])
-> FromJSON NonFederatingBackends
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser NonFederatingBackends
parseJSON :: Value -> Parser NonFederatingBackends
$cparseJSONList :: Value -> Parser [NonFederatingBackends]
parseJSONList :: Value -> Parser [NonFederatingBackends]
FromJSON, [NonFederatingBackends] -> Value
[NonFederatingBackends] -> Encoding
NonFederatingBackends -> Value
NonFederatingBackends -> Encoding
(NonFederatingBackends -> Value)
-> (NonFederatingBackends -> Encoding)
-> ([NonFederatingBackends] -> Value)
-> ([NonFederatingBackends] -> Encoding)
-> ToJSON NonFederatingBackends
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: NonFederatingBackends -> Value
toJSON :: NonFederatingBackends -> Value
$ctoEncoding :: NonFederatingBackends -> Encoding
toEncoding :: NonFederatingBackends -> Encoding
$ctoJSONList :: [NonFederatingBackends] -> Value
toJSONList :: [NonFederatingBackends] -> Value
$ctoEncodingList :: [NonFederatingBackends] -> Encoding
toEncodingList :: [NonFederatingBackends] -> Encoding
ToJSON, Typeable NonFederatingBackends
Typeable NonFederatingBackends =>
(Proxy NonFederatingBackends
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema NonFederatingBackends
Proxy NonFederatingBackends
-> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy NonFederatingBackends
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy NonFederatingBackends
-> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema NonFederatingBackends

instance APIError NonFederatingBackends where
  toResponse :: NonFederatingBackends -> JSONResponse
toResponse NonFederatingBackends
e =
    JSONResponse
      { $sel:status:JSONResponse :: Status
status = Status
nonFederatingBackendsStatus,
        $sel:value:JSONResponse :: Value
value = NonFederatingBackends -> Value
forall a. ToJSON a => a -> Value
toJSON NonFederatingBackends
e
      }

nonFederatingBackendsStatus :: HTTP.Status
nonFederatingBackendsStatus :: Status
nonFederatingBackendsStatus = Status
HTTP.status409

nonFederatingBackendsToList :: NonFederatingBackends -> [Domain]
nonFederatingBackendsToList :: NonFederatingBackends -> [Domain]
nonFederatingBackendsToList (NonFederatingBackends Domain
a Domain
b) = [Domain
a, Domain
b]

nonFederatingBackendsFromList :: (MonadFail m) => [Domain] -> m NonFederatingBackends
nonFederatingBackendsFromList :: forall (m :: * -> *).
MonadFail m =>
[Domain] -> m NonFederatingBackends
nonFederatingBackendsFromList [Domain
a, Domain
b] = NonFederatingBackends -> m NonFederatingBackends
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Domain -> Domain -> NonFederatingBackends
NonFederatingBackends Domain
a Domain
b)
nonFederatingBackendsFromList [Domain]
domains =
  String -> m NonFederatingBackends
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m NonFederatingBackends)
-> String -> m NonFederatingBackends
forall a b. (a -> b) -> a -> b
$
    String
"Expected 2 backends, found " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Domain] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Domain]
domains)

instance ToSchema NonFederatingBackends where
  schema :: ValueSchema NamedSwaggerDoc NonFederatingBackends
schema =
    Text
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     NonFederatingBackends
     NonFederatingBackends
-> ValueSchema NamedSwaggerDoc NonFederatingBackends
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"NonFederatingBackends" (SchemaP
   SwaggerDoc
   Object
   [Pair]
   NonFederatingBackends
   NonFederatingBackends
 -> ValueSchema NamedSwaggerDoc NonFederatingBackends)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     NonFederatingBackends
     NonFederatingBackends
-> ValueSchema NamedSwaggerDoc NonFederatingBackends
forall a b. (a -> b) -> a -> b
$
      SchemaP SwaggerDoc Object [Pair] NonFederatingBackends [Domain]
-> ([Domain] -> Parser NonFederatingBackends)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     NonFederatingBackends
     NonFederatingBackends
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
withParser
        (NonFederatingBackends -> [Domain]
nonFederatingBackendsToList (NonFederatingBackends -> [Domain])
-> SchemaP SwaggerDoc Object [Pair] [Domain] [Domain]
-> SchemaP SwaggerDoc Object [Pair] NonFederatingBackends [Domain]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc 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
"non_federating_backends" (ValueSchema NamedSwaggerDoc Domain
-> SchemaP SwaggerDoc Value Value [Domain] [Domain]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc Domain
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
        [Domain] -> Parser NonFederatingBackends
forall (m :: * -> *).
MonadFail m =>
[Domain] -> m NonFederatingBackends
nonFederatingBackendsFromList

instance IsSwaggerError NonFederatingBackends where
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi =
    Int -> Response -> OpenApi -> OpenApi
addErrorResponseToSwagger (Status -> Int
HTTP.statusCode Status
nonFederatingBackendsStatus) (Response -> OpenApi -> OpenApi) -> Response -> OpenApi -> OpenApi
forall a b. (a -> b) -> a -> b
$
      Response
forall a. Monoid a => a
mempty
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
S.description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Adding members to the conversation is not possible because the backends involved do not form a fully connected graph"
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
S.content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
singleton MediaType
mediaType MediaTypeObject
mediaTypeObject
    where
      mediaType :: MediaType
mediaType = Proxy JSON -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (Proxy JSON -> MediaType) -> Proxy JSON -> MediaType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @JSON
      mediaTypeObject :: MediaTypeObject
mediaTypeObject =
        MediaTypeObject
forall a. Monoid a => a
mempty
          MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline (Proxy NonFederatingBackends -> Schema
forall a. ToSchema a => Proxy a -> Schema
S.toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NonFederatingBackends))

type instance ErrorEffect NonFederatingBackends = Error NonFederatingBackends

instance (Member (Error JSONResponse) r) => ServerEffect (Error NonFederatingBackends) r where
  interpretServerEffect :: forall a. Sem (Error NonFederatingBackends : r) a -> Sem r a
interpretServerEffect = (NonFederatingBackends -> JSONResponse)
-> Sem (Error NonFederatingBackends : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError NonFederatingBackends -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse

--------------------------------------------------------------------------------
-- Unreachable backends

-- | This is returned when adding members to the conversation is not possible
-- because the backends involved do not form a fully connected graph.
data UnreachableBackends = UnreachableBackends {UnreachableBackends -> [Domain]
backends :: [Domain]}
  deriving stock (UnreachableBackends -> UnreachableBackends -> Bool
(UnreachableBackends -> UnreachableBackends -> Bool)
-> (UnreachableBackends -> UnreachableBackends -> Bool)
-> Eq UnreachableBackends
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnreachableBackends -> UnreachableBackends -> Bool
== :: UnreachableBackends -> UnreachableBackends -> Bool
$c/= :: UnreachableBackends -> UnreachableBackends -> Bool
/= :: UnreachableBackends -> UnreachableBackends -> Bool
Eq, Int -> UnreachableBackends -> ShowS
[UnreachableBackends] -> ShowS
UnreachableBackends -> String
(Int -> UnreachableBackends -> ShowS)
-> (UnreachableBackends -> String)
-> ([UnreachableBackends] -> ShowS)
-> Show UnreachableBackends
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnreachableBackends -> ShowS
showsPrec :: Int -> UnreachableBackends -> ShowS
$cshow :: UnreachableBackends -> String
show :: UnreachableBackends -> String
$cshowList :: [UnreachableBackends] -> ShowS
showList :: [UnreachableBackends] -> ShowS
Show, (forall x. UnreachableBackends -> Rep UnreachableBackends x)
-> (forall x. Rep UnreachableBackends x -> UnreachableBackends)
-> Generic UnreachableBackends
forall x. Rep UnreachableBackends x -> UnreachableBackends
forall x. UnreachableBackends -> Rep UnreachableBackends x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UnreachableBackends -> Rep UnreachableBackends x
from :: forall x. UnreachableBackends -> Rep UnreachableBackends x
$cto :: forall x. Rep UnreachableBackends x -> UnreachableBackends
to :: forall x. Rep UnreachableBackends x -> UnreachableBackends
Generic)
  deriving (Value -> Parser [UnreachableBackends]
Value -> Parser UnreachableBackends
(Value -> Parser UnreachableBackends)
-> (Value -> Parser [UnreachableBackends])
-> FromJSON UnreachableBackends
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser UnreachableBackends
parseJSON :: Value -> Parser UnreachableBackends
$cparseJSONList :: Value -> Parser [UnreachableBackends]
parseJSONList :: Value -> Parser [UnreachableBackends]
FromJSON, [UnreachableBackends] -> Value
[UnreachableBackends] -> Encoding
UnreachableBackends -> Value
UnreachableBackends -> Encoding
(UnreachableBackends -> Value)
-> (UnreachableBackends -> Encoding)
-> ([UnreachableBackends] -> Value)
-> ([UnreachableBackends] -> Encoding)
-> ToJSON UnreachableBackends
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: UnreachableBackends -> Value
toJSON :: UnreachableBackends -> Value
$ctoEncoding :: UnreachableBackends -> Encoding
toEncoding :: UnreachableBackends -> Encoding
$ctoJSONList :: [UnreachableBackends] -> Value
toJSONList :: [UnreachableBackends] -> Value
$ctoEncodingList :: [UnreachableBackends] -> Encoding
toEncodingList :: [UnreachableBackends] -> Encoding
ToJSON, Typeable UnreachableBackends
Typeable UnreachableBackends =>
(Proxy UnreachableBackends
 -> Declare (Definitions Schema) NamedSchema)
-> ToSchema UnreachableBackends
Proxy UnreachableBackends
-> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy UnreachableBackends
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy UnreachableBackends
-> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema UnreachableBackends

instance APIError UnreachableBackends where
  toResponse :: UnreachableBackends -> JSONResponse
toResponse UnreachableBackends
e =
    JSONResponse
      { $sel:status:JSONResponse :: Status
status = Status
unreachableBackendsStatus,
        $sel:value:JSONResponse :: Value
value = UnreachableBackends -> Value
forall a. ToJSON a => a -> Value
toJSON UnreachableBackends
e
      }

unreachableBackendsStatus :: HTTP.Status
unreachableBackendsStatus :: Status
unreachableBackendsStatus = Int -> ByteString -> Status
HTTP.mkStatus Int
533 ByteString
"Unreachable backends"

instance ToSchema UnreachableBackends where
  schema :: ValueSchema NamedSwaggerDoc UnreachableBackends
schema =
    Text
-> SchemaP
     SwaggerDoc Object [Pair] UnreachableBackends UnreachableBackends
-> ValueSchema NamedSwaggerDoc UnreachableBackends
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"UnreachableBackends" (SchemaP
   SwaggerDoc Object [Pair] UnreachableBackends UnreachableBackends
 -> ValueSchema NamedSwaggerDoc UnreachableBackends)
-> SchemaP
     SwaggerDoc Object [Pair] UnreachableBackends UnreachableBackends
-> ValueSchema NamedSwaggerDoc UnreachableBackends
forall a b. (a -> b) -> a -> b
$
      [Domain] -> UnreachableBackends
UnreachableBackends
        ([Domain] -> UnreachableBackends)
-> SchemaP SwaggerDoc Object [Pair] UnreachableBackends [Domain]
-> SchemaP
     SwaggerDoc Object [Pair] UnreachableBackends UnreachableBackends
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (.backends) (UnreachableBackends -> [Domain])
-> SchemaP SwaggerDoc Object [Pair] [Domain] [Domain]
-> SchemaP SwaggerDoc Object [Pair] UnreachableBackends [Domain]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc 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
"unreachable_backends" (ValueSchema NamedSwaggerDoc Domain
-> SchemaP SwaggerDoc Value Value [Domain] [Domain]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc Domain
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)

instance IsSwaggerError UnreachableBackends where
  addToOpenApi :: OpenApi -> OpenApi
addToOpenApi =
    Int -> Response -> OpenApi -> OpenApi
addErrorResponseToSwagger (Status -> Int
HTTP.statusCode Status
unreachableBackendsStatus) (Response -> OpenApi -> OpenApi) -> Response -> OpenApi -> OpenApi
forall a b. (a -> b) -> a -> b
$
      Response
forall a. Monoid a => a
mempty
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
S.description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Some domains are unreachable"
        -- Defaulting this to JSON, as openapi3 needs something to map a schema against.
        -- This _should_ be overridden with the actual media types once we are at the
        -- point of rendering out the schemas for MultiVerb.
        -- Check the instance of `S.HasOpenApi (MultiVerb method (cs :: [Type]) as r)`
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
S.content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
singleton MediaType
mediaType MediaTypeObject
mediaTypeObject
    where
      mediaType :: MediaType
mediaType = Proxy JSON -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (Proxy JSON -> MediaType) -> Proxy JSON -> MediaType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @JSON
      mediaTypeObject :: MediaTypeObject
mediaTypeObject = MediaTypeObject
forall a. Monoid a => a
mempty MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
S.Inline (Proxy UnreachableBackends -> Schema
forall a. ToSchema a => Proxy a -> Schema
S.toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @UnreachableBackends))

type instance ErrorEffect UnreachableBackends = Error UnreachableBackends

instance (Member (Error JSONResponse) r) => ServerEffect (Error UnreachableBackends) r where
  interpretServerEffect :: forall a. Sem (Error UnreachableBackends : r) a -> Sem r a
interpretServerEffect = (UnreachableBackends -> JSONResponse)
-> Sem (Error UnreachableBackends : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError UnreachableBackends -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse

unreachableUsersToUnreachableBackends :: UnreachableUsers -> UnreachableBackends
unreachableUsersToUnreachableBackends :: UnreachableUsers -> UnreachableBackends
unreachableUsersToUnreachableBackends =
  [Domain] -> UnreachableBackends
UnreachableBackends
    ([Domain] -> UnreachableBackends)
-> (UnreachableUsers -> [Domain])
-> UnreachableUsers
-> UnreachableBackends
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Domain] -> [Domain]
forall a. Ord a => [a] -> [a]
nubOrd
    ([Domain] -> [Domain])
-> (UnreachableUsers -> [Domain]) -> UnreachableUsers -> [Domain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Qualified UserId -> Domain) -> [Qualified UserId] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map Qualified UserId -> Domain
forall a. Qualified a -> Domain
qDomain
    ([Qualified UserId] -> [Domain])
-> (UnreachableUsers -> [Qualified UserId])
-> UnreachableUsers
-> [Domain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Qualified UserId) -> [Qualified UserId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    (NonEmpty (Qualified UserId) -> [Qualified UserId])
-> (UnreachableUsers -> NonEmpty (Qualified UserId))
-> UnreachableUsers
-> [Qualified UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnreachableUsers -> NonEmpty (Qualified UserId)
unreachableUsers

-- | A newtype wrapper to preserve backward compatibility of the error response
-- for older versions.
newtype UnreachableBackendsLegacy = UnreachableBackendsLegacy UnreachableBackends
  deriving (OpenApi -> OpenApi
(OpenApi -> OpenApi) -> IsSwaggerError UnreachableBackendsLegacy
forall {k} (e :: k). (OpenApi -> OpenApi) -> IsSwaggerError e
$caddToOpenApi :: OpenApi -> OpenApi
addToOpenApi :: OpenApi -> OpenApi
IsSwaggerError)

instance APIError UnreachableBackendsLegacy where
  toResponse :: UnreachableBackendsLegacy -> JSONResponse
toResponse UnreachableBackendsLegacy
_ =
    Error -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse (Error -> JSONResponse) -> Error -> JSONResponse
forall a b. (a -> b) -> a -> b
$
      Status -> LText -> LText -> Error
Wai.mkError
        Status
unreachableBackendsStatus
        LText
"federation-connection-refused"
        LText
"Some backends are unreachable"

type instance ErrorEffect UnreachableBackendsLegacy = Error UnreachableBackendsLegacy

instance (Member (Error JSONResponse) r) => ServerEffect (Error UnreachableBackendsLegacy) r where
  interpretServerEffect :: forall a. Sem (Error UnreachableBackendsLegacy : r) a -> Sem r a
interpretServerEffect = (UnreachableBackendsLegacy -> JSONResponse)
-> Sem (Error UnreachableBackendsLegacy : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError UnreachableBackendsLegacy -> JSONResponse
forall e. APIError e => e -> JSONResponse
toResponse