From bc777ebbc72ebe92e13ff18a3446f7a8e1f11a40 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 7 Jun 2021 09:45:19 +0200 Subject: [PATCH 1/2] wire-api: Introduce ErrorDescription This type will have special instances of HasSwagger so we can express the error responses of a request using UVerb and they will appear correctly in the swagger documentation. --- .../wire-api/src/Wire/API/ErrorDescription.hs | 120 ++++++++++++++++++ .../src/Wire/API/Routes/Public/Galley.hs | 5 +- libs/wire-api/wire-api.cabal | 3 +- services/galley/src/Galley/API/Update.hs | 37 ++++-- 4 files changed, 149 insertions(+), 16 deletions(-) create mode 100644 libs/wire-api/src/Wire/API/ErrorDescription.hs diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs new file mode 100644 index 00000000000..4231fb622c0 --- /dev/null +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -0,0 +1,120 @@ +module Wire.API.ErrorDescription where + +import Control.Lens (at, over, (.~), (?~)) +import Control.Lens.Combinators (_Just) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Schema +import Data.Swagger (PathItem (..), Swagger (..)) +import qualified Data.Swagger as Swagger +import qualified Data.Text as Text +import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, natVal, symbolVal) +import GHC.TypeNats (Nat) +import Imports hiding (head) +import Servant hiding (Handler, JSON, addHeader, contentType, respond) +import Servant.API.Status (KnownStatus) +import Servant.Swagger.Internal + +-- FUTUREWORK: Ponder about elevating label and messge to the type level. If all +-- errors are static, there is probably no point in having them at value level. +data ErrorDescription (statusCode :: Nat) (desc :: Symbol) = ErrorDescription + { label :: !Text, + message :: !Text + } + deriving stock (Show, Typeable) + deriving (A.ToJSON, A.FromJSON, Swagger.ToSchema) via Schema (ErrorDescription statusCode desc) + +instance (KnownNat statusCode, KnownSymbol desc) => ToSchema (ErrorDescription statusCode desc) where + schema = + object "ErrorDescription" $ + ErrorDescription + <$> label .= field "label" schema + <*> message .= field "message" schema + <* const (natVal (Proxy @statusCode)) .= field "code" schema + +-- | This insance works with 'UVerb' only becaue of the following overlapping +-- instance for 'UVerb method cs (ErrorDescription status desc ': rest))' +instance (KnownNat statusCode, KnownSymbol desc, AllAccept cs, SwaggerMethod method) => HasSwagger (Verb method statusCode cs (ErrorDescription statusCode desc)) where + toSwagger _ = overrrideResponseDesc $ mkEndpoint "/" (Proxy @(Verb method statusCode cs (Headers '[] (ErrorDescription statusCode desc)))) + where + overrrideResponseDesc :: Swagger -> Swagger + overrrideResponseDesc = + over (Swagger.paths . at "/" . _Just) overridePathItem + overridePathItem :: Swagger.PathItem -> Swagger.PathItem + overridePathItem = + over (Swagger.get . _Just) overrideOp + . over (Swagger.post . _Just) overrideOp + . over (Swagger.put . _Just) overrideOp + . over (Swagger.head_ . _Just) overrideOp + . over (Swagger.patch . _Just) overrideOp + . over (Swagger.delete . _Just) overrideOp + . over (Swagger.options . _Just) overrideOp + overrideOp :: Swagger.Operation -> Swagger.Operation + overrideOp = + Swagger.responses . Swagger.responses . at (fromInteger $ natVal (Proxy @statusCode)) + ?~ Swagger.Inline + ( mempty + & Swagger.description .~ Text.pack (symbolVal (Proxy @desc)) + & Swagger.schema ?~ Swagger.toSchemaRef (Proxy @(ErrorDescription statusCode desc)) + ) + +-- | This is a copy of instance for 'UVerb method cs (a:as)', but without this +-- things don't work because the instance defined in the library is already +-- compiled with the now overlapped version of `Verb method cs a` and won't +-- pickup the above instance. +instance + (KnownNat status, KnownSymbol desc, AllAccept cs, SwaggerMethod method, HasSwagger (UVerb method cs rest)) => + HasSwagger (UVerb method cs (ErrorDescription status desc ': rest)) + where + toSwagger _ = + toSwagger (Proxy @(Verb method (StatusOf (ErrorDescription status desc)) cs (ErrorDescription status desc))) + `combineSwagger` toSwagger (Proxy @(UVerb method cs rest)) + where + -- workaround for https://github.com/GetShopTV/swagger2/issues/218 + -- We'd like to juse use (<>) but the instances are wrong + combinePathItem :: PathItem -> PathItem -> PathItem + combinePathItem s t = + PathItem + { _pathItemGet = _pathItemGet s <> _pathItemGet t, + _pathItemPut = _pathItemPut s <> _pathItemPut t, + _pathItemPost = _pathItemPost s <> _pathItemPost t, + _pathItemDelete = _pathItemDelete s <> _pathItemDelete t, + _pathItemOptions = _pathItemOptions s <> _pathItemOptions t, + _pathItemHead = _pathItemHead s <> _pathItemHead t, + _pathItemPatch = _pathItemPatch s <> _pathItemPatch t, + _pathItemParameters = _pathItemParameters s <> _pathItemParameters t + } + + combineSwagger :: Swagger -> Swagger -> Swagger + combineSwagger s t = + Swagger + { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t, + _swaggerHost = _swaggerHost s <|> _swaggerHost t, + _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t, + _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t, + _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t, + _swaggerProduces = _swaggerProduces s <> _swaggerProduces t, + _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t), + _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t, + _swaggerParameters = _swaggerParameters s <> _swaggerParameters t, + _swaggerResponses = _swaggerResponses s <> _swaggerResponses t, + _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t, + _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t, + _swaggerTags = _swaggerTags s <> _swaggerTags t, + _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t + } + +instance (KnownNat status, KnownStatus status) => HasStatus (ErrorDescription status desc) where + type StatusOf (ErrorDescription status desc) = status + +-- * Errors + +type ConversationNotFound = ErrorDescription 404 "Conversation not found" + +convNotFound :: ConversationNotFound +convNotFound = ErrorDescription "no-conversation" "conversation not found" + +type UnknownClient = ErrorDescription 403 "Unknown Client" + +unknownClient :: UnknownClient +unknownClient = ErrorDescription "unknown-client" "Sending client not known" diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 57c996d1073..11bce3dece4 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -33,6 +33,7 @@ import Servant.Swagger.Internal import Servant.Swagger.Internal.Orphans () import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public +import Wire.API.ErrorDescription (ConversationNotFound, UnknownClient) import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Message as Public import Wire.API.Routes.Public (EmptyResult, ZConn, ZUser) @@ -50,7 +51,9 @@ type UpdateResponses = type PostOtrResponses = '[ WithStatus 201 Public.ClientMismatch, - WithStatus 412 Public.ClientMismatch + WithStatus 412 Public.ClientMismatch, + ConversationNotFound, + UnknownClient ] -- FUTUREWORK: Make a PR to the servant-swagger package with this instance diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 1594637bd7f..924e5697041 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 363ed356edfc5bd34796bdcf14804d55e5d9faa5ef023a7e10e62219d2261323 +-- hash: 9404af483be016a508ad4a9919330394d673e725945662da3786fe94eb0785e1 name: wire-api version: 0.1.0 @@ -33,6 +33,7 @@ library Wire.API.Conversation.Typing Wire.API.Cookie Wire.API.CustomBackend + Wire.API.ErrorDescription Wire.API.Event.Conversation Wire.API.Event.Team Wire.API.Message diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index bfa40025cc8..24302b956d9 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -113,6 +113,7 @@ import qualified System.Logger.Class as Log import Wire.API.Conversation (InviteQualified (invQRoleName)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public +import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Message as Public import qualified Wire.API.Message.Proto as Proto @@ -607,11 +608,15 @@ removeMember zusr zcon convId victim = do data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch + | OtrUnknownClient !Public.UnknownClient + | OtrConversationNotFound !Public.ConversationNotFound handleOtrResult :: OtrResult -> Galley Response handleOtrResult = \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 + OtrUnknownClient _ -> throwM unknownClient + OtrConversationNotFound _ -> throwM convNotFound postBotMessageH :: BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do @@ -651,6 +656,8 @@ postOtrMessage zusr zcon cnv ignoreMissing reportMissing message = do translateToServant :: OtrResult -> Galley (Union GalleyAPI.PostOtrResponses) translateToServant (OtrSent mismatch) = Servant.respond (WithStatus @201 mismatch) translateToServant (OtrMissingRecipients mismatch) = Servant.respond (WithStatus @412 mismatch) + translateToServant (OtrUnknownClient e) = Servant.respond e + translateToServant (OtrConversationNotFound e) = Servant.respond e resolveQueryMissingOptions :: Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.OtrFilterMissing resolveQueryMissingOptions Nothing Nothing = Public.OtrReportAllMissing @@ -1014,18 +1021,20 @@ withValidOtrRecipients :: Galley OtrResult withValidOtrRecipients protectee clt cnv rcps val now go = do alive <- Data.isConvAlive cnv - unless alive $ do - Data.deleteConversation cnv - throwM convNotFound - -- FUTUREWORK(federation): also handle remote members - (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteMembers, localMembers) <- (undefined,) <$> Data.members cnv - let localMemberIds = memId <$> localMembers - isInternal <- view $ options . optSettings . setIntraListing - clts <- - if isInternal - then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else Data.lookupClients localMemberIds - handleOtrResponse protectee clt rcps localMembers clts val now go + if not alive + then do + Data.deleteConversation cnv + pure $ OtrConversationNotFound Public.convNotFound + else do + -- FUTUREWORK(federation): also handle remote members + (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteMembers, localMembers) <- (undefined,) <$> Data.members cnv + let localMemberIds = memId <$> localMembers + isInternal <- view $ options . optSettings . setIntraListing + clts <- + if isInternal + then Clients.fromUserClients <$> Intra.lookupClients localMemberIds + else Data.lookupClients localMemberIds + handleOtrResponse protectee clt rcps localMembers clts val now go handleOtrResponse :: -- | Proposed sender (user) @@ -1050,8 +1059,8 @@ handleOtrResponse protectee clt rcps membs clts val now go = case checkOtrRecipi MissingOtrRecipients m -> do guardLegalholdPolicyConflicts (legalholdProtectee'2LegalholdProtectee protectee) (missingClients m) pure (OtrMissingRecipients m) - InvalidOtrSenderUser -> throwM convNotFound - InvalidOtrSenderClient -> throwM unknownClient + InvalidOtrSenderUser -> pure $ OtrConversationNotFound Public.convNotFound + InvalidOtrSenderClient -> pure $ OtrUnknownClient Public.unknownClient -- | Check OTR sender and recipients for validity and completeness -- against a given list of valid members and clients, optionally From 68ea3197a9c64f31e75c048b2fc22e9624687df2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 7 Jun 2021 12:04:23 +0200 Subject: [PATCH 2/2] Fix typo --- libs/wire-api/src/Wire/API/ErrorDescription.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 4231fb622c0..ae8bcd30bf6 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -32,7 +32,7 @@ instance (KnownNat statusCode, KnownSymbol desc) => ToSchema (ErrorDescription s <*> message .= field "message" schema <* const (natVal (Proxy @statusCode)) .= field "code" schema --- | This insance works with 'UVerb' only becaue of the following overlapping +-- | This instance works with 'UVerb' only becaue of the following overlapping -- instance for 'UVerb method cs (ErrorDescription status desc ': rest))' instance (KnownNat statusCode, KnownSymbol desc, AllAccept cs, SwaggerMethod method) => HasSwagger (Verb method statusCode cs (ErrorDescription statusCode desc)) where toSwagger _ = overrrideResponseDesc $ mkEndpoint "/" (Proxy @(Verb method statusCode cs (Headers '[] (ErrorDescription statusCode desc))))