[WIP] Move post otr message endpoint to servant

The tests are not enough, they don't test lists being sent to ignore_missing and report_missing
wireapp · May 26, 2021 · c64fff9 · c64fff9
1 parent e633b8d
commit c64fff9
Show file tree

Hide file tree

Showing 7 changed files with 197 additions and 115 deletions.
diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs
@@ -42,11 +42,12 @@ module Wire.API.Message
   )
 where
 
-import Data.Aeson
+import qualified Data.Aeson as A
 import Data.Id
 import Data.Json.Util
+import Data.Schema
+import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
-import Data.Time
 import Imports
 import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..))
 import Wire.API.User.Client (UserClientMap (..), UserClients (..), modelOtrClientMap, modelUserClients)
@@ -69,6 +70,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 +97,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 +125,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 +135,11 @@ 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" $
+      element "low" LowPriority
+        <|> element "high" HighPriority
 
 --------------------------------------------------------------------------------
 -- Recipients
@@ -161,7 +149,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
@@ -189,22 +177,24 @@ data OtrFilterMissing
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform OtrFilterMissing)
 
+-- TODO: Verify if the change from UTCTime to UTCTimeMillis has any significant
+-- effect. The ToJSON instance was already translating it to millis and fromJSON
+-- didn't care for it (as it is never being sent by clients)
 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 +208,11 @@ 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
diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs
@@ -21,8 +21,9 @@
 module Wire.API.Routes.Public.Galley where
 
 import Data.CommaSeparatedList
-import Data.Id (ConvId, TeamId)
+import Data.Id (ConvId, TeamId, UserId)
 import Data.Range
+import qualified Data.Set as Set
 import Data.Swagger
 import Imports hiding (head)
 import Servant hiding (Handler, JSON, addHeader, contentType, respond)
@@ -34,6 +35,7 @@ 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
 
@@ -47,6 +49,11 @@ 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 @())
@@ -205,11 +212,93 @@ 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)"
+        :> ZUser
+        :> ZConn
+        :> "conversations"
+        :> Capture "cnv" ConvId
+        :> QueryParam "ignore_missing" IgnoreMissing
+        :> QueryParam "report_missing" ReportMissing
+        :> "otr"
+        :> "messages"
+        :> ReqBody '[Servant.JSON] Public.NewOtrMessage
+        :> UVerb 'POST '[Servant.JSON] PostOtrResponses
   }
   deriving (Generic)
 
 type ServantAPI = ToServantApi Api
 
+data IgnoreMissing
+  = IgnoreMissingAll
+  | IgnoreMissingList (Set UserId)
+  deriving (Show, Eq)
+
+-- TODO: Fill this in
+instance ToParamSchema IgnoreMissing where
+  toParamSchema _ = mempty
+
+-- TODO: Test what happens when empty string is sent, is it backwards compatible?
+-- TODO: Test what happens when true and false have different cases, is it backwards compatible?
+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 ToParamSchema ReportMissing where
+  toParamSchema _ = mempty
+
+-- TODO: Test what happens when empty string is sent, is it backwards compatible?
+-- TODO: Test what happens when true and false have different cases, is it backwards compatible?
+instance FromHttpApiData ReportMissing where
+  parseQueryParam = \case
+    "true" -> Right ReportMissingAll
+    "false" -> Right $ ReportMissingList mempty
+    list -> ReportMissingList . Set.fromList . fromCommaSeparatedList <$> parseQueryParam list
+
 swaggerDoc :: Swagger
 swaggerDoc = toSwagger (Proxy @ServantAPI)
+
+-- post "/conversations/:cnv/otr/messages" (continue Update.postOtrMessageH) $
+--     zauthUserId
+--       .&. zauthConnId
+--       .&. capture "cnv"
+--       .&. def Public.OtrReportAllMissing filterMissing
+--       .&. jsonRequest @Public.NewOtrMessage
+--   document "POST" "postOtrMessage" $ do
+--     summary "Post an encrypted message to a conversation (accepts JSON)"
+--     parameter Path "cnv" bytes' $
+--       description "Conversation ID"
+--     parameter Query "ignore_missing" bool' $ do
+--       description
+--         "Force message delivery even when clients are missing. \
+--         \NOTE: can also be a comma-separated list of user IDs, \
+--         \in which case it specifies who exactly is allowed to \
+--         \have missing clients."
+--       optional
+--     parameter Query "report_missing" bool' $ do
+--       description
+--         "Don't allow message delivery when clients are missing \
+--         \('ignore_missing' takes precedence when present). \
+--         \NOTE: can also be a comma-separated list of user IDs, \
+--         \in which case it specifies who exactly is forbidden from \
+--         \having missing clients. \
+--         \To support large lists of user IDs exceeding the allowed \
+--         \URL length, you can also put this list in the body, in \
+--         \the optional field 'report_missing'.  That body field takes \
+--         \prhttps://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/376439791/Use%2Bcase%2BClassified%2Bdomains?focusedCommentId=384861252#comment-384861252ecedence over both query params."
+--       optional
+--     body (ref Public.modelNewOtrMessage) $
+--       description "JSON body"
+--     returns (ref Public.modelClientMismatch)
+--     response 201 "Message posted" end
+--     response 412 "Missing clients" end
+--     errorResponse Error.convNotFound
+--     errorResponse Error.unknownClient
diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs
@@ -74,7 +74,6 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as A
 import Data.Coerce
 import Data.Domain (Domain)
-import qualified Data.HashMap.Strict as HashMap
 import Data.Id
 import Data.Json.Util
 import qualified Data.Map.Strict as Map
@@ -84,8 +83,6 @@ import Data.Schema
 import qualified Data.Set as Set
 import qualified Data.Swagger as Swagger
 import qualified Data.Swagger.Build.Api as Doc
-import qualified Data.Text.Encoding as Text.E
-import Data.UUID (toASCIIBytes)
 import Deriving.Swagger
   ( CamelToSnake,
     ConstructorTagModifier,
@@ -303,43 +300,32 @@ newtype UserClients = UserClients
   }
   deriving stock (Eq, Show, Generic)
   deriving newtype (Semigroup, Monoid)
+  deriving (ToJSON, FromJSON, Swagger.ToSchema) via Schema UserClients
 
-instance Swagger.ToSchema UserClients where
-  declareNamedSchema _ = do
-    mapSch <- Swagger.declareSchema (Proxy @(Map UserId (Set ClientId)))
-    return $
-      Swagger.NamedSchema (Just "UserClients") $
-        mapSch
-          & Swagger.description ?~ "Map of user id to list of client ids."
-          & Swagger.example
+-- TODO: Is using genericToSchema OK here? Maybe it is better to write a `set`
+-- combinator?
+instance ToSchema UserClients where
+  schema =
+    addDoc . named "UserClients" $ UserClients <$> userClients .= map_ (genericToSchema @(Set ClientId))
+    where
+      addDoc sch =
+        sch
+          & Swagger.schema . Swagger.description ?~ "Map of user id to list of client ids."
+          & Swagger.schema . Swagger.example
             ?~ toJSON
               ( Map.fromList
                   [ (generateExample @UserId, [newClientId 1684636986166846496, newClientId 4940483633899001999]),
                     (generateExample @UserId, [newClientId 6987438498444556166, newClientId 7940473633839002939])
                   ]
               )
 
--- FUTUREWORK: Remove when 'NewOtrMessage' has ToSchema
+-- TODO: Remove when 'NewOtrMessage' has ToSchema
 modelUserClients :: Doc.Model
 modelUserClients =
   Doc.defineModel "UserClients" $
     Doc.property "" (Doc.unique $ Doc.array Doc.bytes') $
       Doc.description "Map of user IDs to sets of client IDs ({ UserId: [ClientId] })."
 
-instance ToJSON UserClients where
-  toJSON =
-    toJSON . Map.foldrWithKey' fn Map.empty . userClients
-    where
-      fn u c m =
-        let k = Text.E.decodeLatin1 (toASCIIBytes (toUUID u))
-         in Map.insert k c m
-
-instance FromJSON UserClients where
-  parseJSON =
-    A.withObject "UserClients" (fmap UserClients . foldrM fn Map.empty . HashMap.toList)
-    where
-      fn (k, v) m = Map.insert <$> parseJSON (A.String k) <*> parseJSON v <*> pure m
-
 instance Arbitrary UserClients where
   arbitrary = UserClients <$> mapOf' arbitrary (setOf' arbitrary)