wire-api: Introduce ErrorDescription

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 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))))
+    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"

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

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

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