[WIP] Experimental errors with UVerb

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) $

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