Servantify JSON endpoint to send messages (#1532)

Also: - Add combinator for `Data.Set.Set` in schema-profunctor - Add `ToSchema` instance for `Integer` - Add tests to verify comma separated list in ignore_missing and report_missing query params - Document the precedence of various ways to ignore missing clients
wireapp · Jun 3, 2021 · 0c3ef6e · 0c3ef6e
1 parent ed7e93f
commit 0c3ef6e
Show file tree

Hide file tree

Showing 11 changed files with 239 additions and 191 deletions.
diff --git a/libs/schema-profunctor/package.yaml b/libs/schema-profunctor/package.yaml
@@ -23,6 +23,7 @@ library:
     - text
     - transformers
     - vector
+    - containers
 tests:
   schemas-tests:
     main: Main.hs

diff --git a/libs/schema-profunctor/schema-profunctor.cabal b/libs/schema-profunctor/schema-profunctor.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 11ed18fc8f6fc6cc51f29a022f7695bc086b893b80a35ed8beb5f0840d1d8b45
+-- hash: f1d1bde721143e6e1f8346c434abffcc73f4d5c58eb40d463f337805bbfff766
 
 name:           schema-profunctor
 version:        0.1.0
@@ -31,6 +31,7 @@ library
     , base >=4 && <5
     , bifunctors
     , comonad
+    , containers
     , imports
     , lens
     , profunctors

diff --git a/libs/schema-profunctor/src/Data/Schema.hs b/libs/schema-profunctor/src/Data/Schema.hs
@@ -47,6 +47,7 @@ module Data.Schema
     fieldWithDocModifier,
     fieldOver,
     array,
+    set,
     nonEmptyArray,
     map_,
     enum,
@@ -72,7 +73,8 @@ where
 
 import Control.Applicative
 import Control.Comonad
-import Control.Lens hiding (element, enum, (.=))
+import Control.Lens hiding (element, enum, set, (.=))
+import qualified Control.Lens as Lens
 import Control.Monad.Trans.Cont
 import qualified Data.Aeson.Types as A
 import Data.Bifunctor.Joker
@@ -81,6 +83,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.Monoid hiding (Product)
 import Data.Profunctor (Star (..))
 import Data.Proxy (Proxy (..))
+import qualified Data.Set as Set
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Declare as S
 import qualified Data.Text as T
@@ -232,7 +235,7 @@ instance Choice (SchemaP doc v v') where
   right' (SchemaP d i o) = SchemaP (right' d) (right' i) (right' o)
 
 instance HasDoc (SchemaP doc v v' a b) (SchemaP doc' v v' a b) doc doc' where
-  doc = lens schemaDoc $ \(SchemaP d i o) d' -> SchemaP (set doc d' d) i o
+  doc = lens schemaDoc $ \(SchemaP d i o) d' -> SchemaP (Lens.set doc d' d) i o
 
 withParser :: SchemaP doc v w a b -> (b -> A.Parser b') -> SchemaP doc v w a b'
 withParser (SchemaP (SchemaDoc d) (SchemaIn p) (SchemaOut o)) q =
@@ -367,6 +370,18 @@ array sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
     s = mkArray (schemaDoc sch)
     w x = A.Array . V.fromList <$> mapM (schemaOut sch) x
 
+set ::
+  (HasArray ndoc doc, HasName ndoc, Ord a) =>
+  ValueSchema ndoc a ->
+  ValueSchema doc (Set a)
+set sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
+  where
+    name = maybe "set" ("set of " <>) (getName (schemaDoc sch))
+    r = A.withArray (T.unpack name) $ \arr ->
+      fmap Set.fromList . mapM (schemaIn sch) $ V.toList arr
+    s = mkArray (schemaDoc sch)
+    w x = A.Array . V.fromList <$> mapM (schemaOut sch) (Set.toList x)
+
 nonEmptyArray ::
   (HasArray ndoc doc, HasName ndoc, HasMinItems doc (Maybe Integer)) =>
   ValueSchema ndoc a ->
@@ -706,6 +721,8 @@ instance ToSchema Int32 where schema = genericToSchema
 
 instance ToSchema Int64 where schema = genericToSchema
 
+instance ToSchema Integer where schema = genericToSchema
+
 instance ToSchema Word where schema = genericToSchema
 
 instance ToSchema Word8 where schema = genericToSchema

diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs
@@ -33,6 +33,8 @@ module Wire.API.Message
     OtrFilterMissing (..),
     ClientMismatch (..),
     UserClients (..),
+    ReportMissing (..),
+    IgnoreMissing (..),
 
     -- * Swagger
     modelNewOtrMessage,
@@ -42,12 +44,17 @@ module Wire.API.Message
   )
 where
 
-import Data.Aeson
+import Control.Lens ((?~))
+import qualified Data.Aeson as A
+import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList))
 import Data.Id
 import Data.Json.Util
+import Data.Schema
+import qualified Data.Set as Set
+import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
-import Data.Time
 import Imports
+import Servant (FromHttpApiData (..))
 import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..))
 import Wire.API.User.Client (UserClientMap (..), UserClients (..), modelOtrClientMap, modelUserClients)
 
@@ -69,6 +76,7 @@ data NewOtrMessage = NewOtrMessage
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform NewOtrMessage)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema NewOtrMessage)
 
 modelNewOtrMessage :: Doc.Model
 modelNewOtrMessage = Doc.defineModel "NewOtrMessage" $ do
@@ -95,28 +103,17 @@ modelNewOtrMessage = Doc.defineModel "NewOtrMessage" $ do
     Doc.description "List of user IDs"
     Doc.optional
 
-instance ToJSON NewOtrMessage where
-  toJSON otr =
-    object $
-      "sender" .= newOtrSender otr
-        # "recipients" .= newOtrRecipients otr
-        # "native_push" .= newOtrNativePush otr
-        # "transient" .= newOtrTransient otr
-        # "native_priority" .= newOtrNativePriority otr
-        # "data" .= newOtrData otr
-        # "report_missing" .= newOtrReportMissing otr
-        # []
-
-instance FromJSON NewOtrMessage where
-  parseJSON = withObject "new-otr-message" $ \o ->
-    NewOtrMessage
-      <$> o .: "sender"
-      <*> o .: "recipients"
-      <*> o .:? "native_push" .!= True
-      <*> o .:? "transient" .!= False
-      <*> o .:? "native_priority"
-      <*> o .:? "data"
-      <*> o .:? "report_missing"
+instance ToSchema NewOtrMessage where
+  schema =
+    object "new-otr-message" $
+      NewOtrMessage
+        <$> newOtrSender .= field "sender" schema
+        <*> newOtrRecipients .= field "recipients" schema
+        <*> newOtrNativePush .= (field "native_push" schema <|> pure True)
+        <*> newOtrTransient .= (field "transient" schema <|> pure False)
+        <*> newOtrNativePriority .= opt (field "native_priority" schema)
+        <*> newOtrData .= opt (field "data" schema)
+        <*> newOtrReportMissing .= opt (field "report_missing" (array schema))
 
 --------------------------------------------------------------------------------
 -- Priority
@@ -134,6 +131,7 @@ instance FromJSON NewOtrMessage where
 data Priority = LowPriority | HighPriority
   deriving stock (Eq, Show, Ord, Enum, Generic)
   deriving (Arbitrary) via (GenericUniform Priority)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema Priority
 
 typePriority :: Doc.DataType
 typePriority =
@@ -143,15 +141,13 @@ typePriority =
         "high"
       ]
 
-instance ToJSON Priority where
-  toJSON LowPriority = String "low"
-  toJSON HighPriority = String "high"
-
-instance FromJSON Priority where
-  parseJSON = withText "Priority" $ \case
-    "low" -> pure LowPriority
-    "high" -> pure HighPriority
-    x -> fail $ "Invalid push priority: " ++ show x
+instance ToSchema Priority where
+  schema =
+    enum @Text "Priority" $
+      mconcat
+        [ element "low" LowPriority,
+          element "high" HighPriority
+        ]
 
 --------------------------------------------------------------------------------
 -- Recipients
@@ -161,7 +157,7 @@ newtype OtrRecipients = OtrRecipients
   { otrRecipientsMap :: UserClientMap Text
   }
   deriving stock (Eq, Show)
-  deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Arbitrary)
+  deriving newtype (ToSchema, A.ToJSON, A.FromJSON, Semigroup, Monoid, Arbitrary)
 
 -- FUTUREWORK: Remove when 'NewOtrMessage' has ToSchema
 modelOtrRecipients :: Doc.Model
@@ -190,21 +186,20 @@ data OtrFilterMissing
   deriving (Arbitrary) via (GenericUniform OtrFilterMissing)
 
 data ClientMismatch = ClientMismatch
-  { cmismatchTime :: UTCTime,
+  { cmismatchTime :: UTCTimeMillis,
     -- | Clients that the message /should/ have been encrypted for, but wasn't.
     missingClients :: UserClients,
     -- | Clients that the message /should not/ have been encrypted for, but was.
     redundantClients :: UserClients,
     deletedClients :: UserClients
   }
   deriving stock (Eq, Show, Generic)
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema ClientMismatch
 
 instance Arbitrary ClientMismatch where
   arbitrary =
     ClientMismatch
-      <$> (milli <$> arbitrary) <*> arbitrary <*> arbitrary <*> arbitrary
-    where
-      milli = fromUTCTimeMillis . toUTCTimeMillis
+      <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 
 modelClientMismatch :: Doc.Model
 modelClientMismatch = Doc.defineModel "ClientMismatch" $ do
@@ -218,19 +213,40 @@ modelClientMismatch = Doc.defineModel "ClientMismatch" $ do
   Doc.property "deleted" (Doc.ref modelUserClients) $
     Doc.description "Map of deleted clients per user."
 
-instance ToJSON ClientMismatch where
-  toJSON m =
-    object
-      [ "time" .= toUTCTimeMillis (cmismatchTime m),
-        "missing" .= missingClients m,
-        "redundant" .= redundantClients m,
-        "deleted" .= deletedClients m
-      ]
-
-instance FromJSON ClientMismatch where
-  parseJSON = withObject "ClientMismatch" $ \o ->
-    ClientMismatch
-      <$> o .: "time"
-      <*> o .: "missing"
-      <*> o .: "redundant"
-      <*> o .: "deleted"
+instance ToSchema ClientMismatch where
+  schema =
+    object "ClientMismatch" $
+      ClientMismatch
+        <$> cmismatchTime .= field "time" schema
+        <*> missingClients .= field "missing" schema
+        <*> redundantClients .= field "redundant" schema
+        <*> deletedClients .= field "deleted" schema
+
+-- QueryParams
+
+data IgnoreMissing
+  = IgnoreMissingAll
+  | IgnoreMissingList (Set UserId)
+  deriving (Show, Eq)
+
+instance S.ToParamSchema IgnoreMissing where
+  toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString
+
+instance FromHttpApiData IgnoreMissing where
+  parseQueryParam = \case
+    "true" -> Right IgnoreMissingAll
+    "false" -> Right $ IgnoreMissingList mempty
+    list -> IgnoreMissingList . Set.fromList . fromCommaSeparatedList <$> parseQueryParam list
+
+data ReportMissing
+  = ReportMissingAll
+  | ReportMissingList (Set UserId)
+
+instance S.ToParamSchema ReportMissing where
+  toParamSchema _ = mempty & S.type_ ?~ S.SwaggerString
+
+instance FromHttpApiData ReportMissing where
+  parseQueryParam = \case
+    "true" -> Right ReportMissingAll
+    "false" -> Right $ ReportMissingList mempty
+    list -> ReportMissingList . Set.fromList . fromCommaSeparatedList <$> parseQueryParam list
diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs
@@ -24,7 +24,7 @@ import Data.CommaSeparatedList
 import Data.Domain
 import Data.Id (ConvId, TeamId)
 import Data.Range
-import Data.Swagger
+import qualified Data.Swagger as Swagger
 import Imports hiding (head)
 import Servant hiding (Handler, JSON, addHeader, contentType, respond)
 import qualified Servant
@@ -34,7 +34,7 @@ import Servant.Swagger.Internal.Orphans ()
 import qualified Wire.API.Conversation as Public
 import qualified Wire.API.Conversation.Role as Public
 import qualified Wire.API.Event.Conversation as Public
-import qualified Wire.API.Event.Team as Public ()
+import qualified Wire.API.Message as Public
 import Wire.API.Routes.Public (EmptyResult, ZConn, ZUser)
 import qualified Wire.API.Team.Conversation as Public
 
@@ -48,9 +48,14 @@ type UpdateResponses =
      NoContent
    ]
 
+type PostOtrResponses =
+  '[ WithStatus 201 Public.ClientMismatch,
+     WithStatus 412 Public.ClientMismatch
+   ]
+
 -- 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
@@ -213,11 +218,46 @@ data Api routes = Api
         :> Capture "tid" TeamId
         :> "conversations"
         :> Capture "cid" ConvId
-        :> Delete '[] (EmptyResult 200)
+        :> Delete '[] (EmptyResult 200),
+    postOtrMessage ::
+      routes
+        :- Summary "Post an encrypted message to a conversation (accepts JSON)"
+        :> Description PostOtrDescription
+        :> ZUser
+        :> ZConn
+        :> "conversations"
+        :> Capture "cnv" ConvId
+        :> QueryParam "ignore_missing" Public.IgnoreMissing
+        :> QueryParam "report_missing" Public.ReportMissing
+        :> "otr"
+        :> "messages"
+        :> ReqBody '[Servant.JSON] Public.NewOtrMessage
+        :> UVerb 'POST '[Servant.JSON] PostOtrResponses
   }
   deriving (Generic)
 
 type ServantAPI = ToServantApi Api
 
-swaggerDoc :: Swagger
+type PostOtrDescription =
+  "This endpoint ensures that the list of clients is correct and only sends the message if the list is correct.\n\
+  \To override this, the endpoint accepts two query params:\n\
+  \- `ignore_missing`: Can be 'true' 'false' or a comma separated list of user IDs.\n\
+  \  - When 'true' all missing clients are ignored.\n\
+  \  - When 'false' all missing clients are reported.\n\
+  \  - When comma separated list of user-ids, only clients for listed users are ignored.\n\
+  \- `report_missing`: Can be 'true' 'false' or a comma separated list of user IDs.\n\
+  \  - When 'true' all missing clients are reported.\n\
+  \  - When 'false' all missing clients are ignored.\n\
+  \  - When comma separated list of user-ids, only clients for listed users are reported.\n\
+  \\n\
+  \Apart from these, the request body also accepts `report_missing` which can only be a list of user ids and behaves the same way as the query parameter.\n\
+  \\n\
+  \All three of these should be considered mutually exclusive. The server however does not error if more than one is specified, it reads them in this order of precedence:\n\
+  \- `report_missing` in the request body has highest precedence.\n\
+  \- `ignore_missing` in the query param is the next.\n\
+  \- `report_missing` in the query param has the lowest precedence.\n\
+  \\n\
+  \This endpoint can lead to OtrMessageAdd event being sent to the recipients."
+
+swaggerDoc :: Swagger.Swagger
 swaggerDoc = toSwagger (Proxy @ServantAPI)