From 9644c0e963481ef4e581a7f5f73545a163e81665 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 31 May 2021 18:00:09 +0200 Subject: [PATCH] [WIP] Experimental errors with UVerb --- .../src/Wire/API/Routes/Public/Galley.hs | 130 +++++++++++++++++- services/galley/src/Galley/API/Update.hs | 50 ++++--- 2 files changed, 152 insertions(+), 28 deletions(-) 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 376cfc0d4fe..b939ff86813 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -20,15 +20,26 @@ module Wire.API.Routes.Public.Galley where +import Control.Lens (at, over, (.~), (?~)) +import Control.Lens.Combinators (_Just) +import qualified Data.Aeson as A import Data.CommaSeparatedList +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id (ConvId, TeamId, UserId) import Data.Range +import Data.Schema import qualified Data.Set as Set -import Data.Swagger +import Data.Swagger (PathItem (..), Swagger (..)) +import qualified Data.Swagger as Swagger +import qualified Data.Text as Text +import qualified Debug.Trace as Debug +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 qualified Servant import Servant.API.Generic (ToServantApi, (:-)) +import Servant.API.Status (KnownStatus) import Servant.Swagger.Internal import Servant.Swagger.Internal.Orphans () import qualified Wire.API.Conversation as Public @@ -49,14 +60,119 @@ type UpdateResponses = NoContent ] +data ErrorDescription (status :: Nat) (desc :: Symbol) = ErrorDescription + { label :: !Text, + message :: !Text + } + deriving stock (Show, Typeable) + deriving (A.ToJSON, A.FromJSON, Swagger.ToSchema) via Schema (ErrorDescription status desc) + +instance (KnownNat status, KnownSymbol desc) => ToSchema (ErrorDescription status desc) where + schema = + addDoc $ + object "ErrorDescription" $ + ErrorDescription + <$> label .= field "label" schema + <*> message .= field "message" schema + <* const (natVal (Proxy @status)) .= field "status" genericToSchema + where + -- FUTUREWORK: Make this description go into swagger's response + -- description + addDoc sch = + sch + & Swagger.schema . Swagger.description ?~ Text.pack (symbolVal (Proxy @desc)) + +instance (KnownNat status, KnownSymbol desc, AllAccept cs, SwaggerMethod method) => HasSwagger (Verb method status cs (ErrorDescription status desc)) where + toSwagger _ = Debug.trace "wooooo" $ overrrideResponseDesc $ mkEndpoint "/" (Proxy @(Verb method status cs (Headers '[] (ErrorDescription status 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 @status)) + ?~ Swagger.Inline + ( mempty + & Swagger.description .~ Text.pack (symbolVal (Proxy @desc)) + & Swagger.schema ?~ Swagger.toSchemaRef (Proxy @(ErrorDescription status desc)) + ) + +-- TODO: This is a copy of instance for 'UVerb method cs (a:as)', but without +-- this things don't work. Something is shadily overlapping here! +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 + +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" + 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 -instance ToSchema Servant.NoContent where - declareNamedSchema _ = declareNamedSchema (Proxy @()) +instance Swagger.ToSchema Servant.NoContent where + declareNamedSchema _ = Swagger.declareNamedSchema (Proxy @()) data Api routes = Api { -- Conversations @@ -243,7 +359,7 @@ data IgnoreMissing deriving (Show, Eq) -- TODO: Fill this in -instance ToParamSchema IgnoreMissing where +instance Swagger.ToParamSchema IgnoreMissing where toParamSchema _ = mempty -- TODO: Test what happens when empty string is sent, is it backwards compatible? @@ -258,7 +374,7 @@ data ReportMissing = ReportMissingAll | ReportMissingList (Set UserId) -instance ToParamSchema ReportMissing where +instance Swagger.ToParamSchema ReportMissing where toParamSchema _ = mempty -- TODO: Test what happens when empty string is sent, is it backwards compatible? @@ -269,7 +385,7 @@ instance FromHttpApiData ReportMissing where "false" -> Right $ ReportMissingList mempty list -> ReportMissingList . Set.fromList . fromCommaSeparatedList <$> parseQueryParam list -swaggerDoc :: Swagger +swaggerDoc :: Swagger.Swagger swaggerDoc = toSwagger (Proxy @ServantAPI) -- post "/conversations/:cnv/otr/messages" (continue Update.postOtrMessageH) $ diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 480ca8e5ea5..2f90c3ae176 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -620,17 +620,21 @@ removeMember zusr zcon convId victim = do data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch + | OtrUnknownClient !GalleyAPI.UnknownClient + | OtrConversationNotFound !GalleyAPI.ConversationNotFound -handleOtrResult :: OtrResult -> Response +handleOtrResult :: OtrResult -> Galley Response handleOtrResult = \case - OtrSent m -> json m & setStatus status201 - OtrMissingRecipients m -> json m & setStatus status412 + 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 message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult <$> postBotMessage zbot zcnv val' message + handleOtrResult =<< postBotMessage zbot zcnv val' message data LegalholdProtectee' = ProtectedUser' UserId @@ -653,7 +657,7 @@ postProtoOtrMessageH :: UserId ::: ConnId ::: ConvId ::: Public.OtrFilterMissing postProtoOtrMessageH (zusr ::: zcon ::: cnv ::: val ::: req ::: _) = do message <- Proto.toNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult <$> postNewOtrMessage (ProtectedUser' zusr) (Just zcon) cnv val' message + handleOtrResult =<< postNewOtrMessage (ProtectedUser' zusr) (Just zcon) cnv val' message postOtrMessage :: UserId -> ConnId -> ConvId -> Maybe GalleyAPI.IgnoreMissing -> Maybe GalleyAPI.ReportMissing -> Public.NewOtrMessage -> Galley (Union GalleyAPI.PostOtrResponses) postOtrMessage zusr zcon cnv ignoreMissing reportMissing message = do @@ -664,6 +668,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 GalleyAPI.IgnoreMissing -> Maybe GalleyAPI.ReportMissing -> Public.OtrFilterMissing resolveQueryMissingOptions Nothing Nothing = Public.OtrReportAllMissing @@ -676,13 +682,13 @@ postProtoOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: Requ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do message <- Proto.toNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult <$> postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult <$> postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult postOtrBroadcast zusr zcon val message = @@ -1006,18 +1012,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 GalleyAPI.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) @@ -1042,8 +1050,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 GalleyAPI.convNotFound + InvalidOtrSenderClient -> pure $ OtrUnknownClient GalleyAPI.unknownClient -- | Check OTR sender and recipients for validity and completeness -- against a given list of valid members and clients, optionally