Merge remote-tracking branch 'origin/develop' into pcapriotti/federat…

…or-galley
wireapp · Jun 4, 2021 · 0620cb8 · 0620cb8
2 parents bf4c341 + 52da58a
commit 0620cb8
Show file tree

Hide file tree

Showing 137 changed files with 3,469 additions and 1,099 deletions.
diff --git a/libs/api-client/src/Network/Wire/Client/API/Push.hs b/libs/api-client/src/Network/Wire/Client/API/Push.hs
@@ -36,6 +36,7 @@ module Network.Wire.Client.API.Push
     OtrMessage (..),
     SimpleMembers (..),
     SimpleMember (..),
+    smId,
     UserIdList (..),
     UserInfo (..),
 

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/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs
@@ -26,6 +26,7 @@ module Wire.API.Event.Conversation
 
     -- * Event data helpers
     SimpleMember (..),
+    smId,
     SimpleMembers (..),
     Connect (..),
     MemberUpdateData (..),
@@ -70,6 +71,7 @@ import qualified Data.Aeson as A
 import qualified Data.HashMap.Strict as HashMap
 import Data.Id
 import Data.Json.Util (ToJSONObject (toJSONObject), UTCTimeMillis (fromUTCTimeMillis), toUTCTimeMillis)
+import Data.Qualified
 import Data.Schema
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
@@ -89,8 +91,8 @@ import Wire.API.User (UserIdList (..))
 
 data Event = Event
   { evtType :: EventType,
-    evtConv :: ConvId, -- FUTUREWORK: make this qualified
-    evtFrom :: UserId, -- FUTUREWORK: make this qualified
+    evtConv :: Qualified ConvId,
+    evtFrom :: Qualified UserId,
     evtTime :: UTCTime,
     evtData :: EventData
   }
@@ -294,26 +296,17 @@ newtype SimpleMembers = SimpleMembers
   deriving (FromJSON, ToJSON, S.ToSchema) via Schema SimpleMembers
 
 instance ToSchema SimpleMembers where
-  schema = object "Members" simpleMembersObjectSchema
-
-simpleMembersObjectSchema :: ObjectSchema SwaggerDoc SimpleMembers
-simpleMembersObjectSchema =
-  (`withParser` either fail pure) $
-    mk
-      <$> mMembers .= optional (field "users" (array schema))
-      <*> (fmap smId . mMembers)
-        .= optional
-          ( fieldWithDocModifier
-              "user_ids"
-              (description ?~ "deprecated")
-              (array schema)
-          )
-  where
-    -- This is to make migration easier and not dependent on deployment ordering
-    mk :: Maybe [SimpleMember] -> Maybe [UserId] -> Either String SimpleMembers
-    mk Nothing Nothing = Left "Either users or user_ids required"
-    mk Nothing (Just ids) = pure (SimpleMembers (fmap (\u -> SimpleMember u roleNameWireAdmin) ids))
-    mk (Just membs) _ = pure (SimpleMembers membs)
+  schema =
+    object "Members" $
+      SimpleMembers
+        <$> mMembers .= field "users" (array schema)
+        <* (fmap smId . mMembers)
+          .= optional
+            ( fieldWithDocModifier
+                "user_ids"
+                (description ?~ "deprecated")
+                (array schema)
+            )
 
 -- | Used both for 'SimpleMembers' and 'UserIdList'.
 modelMembers :: Doc.Model
@@ -323,32 +316,24 @@ modelMembers =
       Doc.description "List of user IDs"
 
 data SimpleMember = SimpleMember
-  { smId :: UserId,
+  { smQualifiedId :: Qualified UserId,
     smConvRoleName :: RoleName
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform SimpleMember)
+  deriving (FromJSON, ToJSON) via Schema SimpleMember
+
+smId :: SimpleMember -> UserId
+smId = qUnqualified . smQualifiedId
 
 instance ToSchema SimpleMember where
   schema =
     object "SimpleMember" $
       SimpleMember
-        <$> smId .= field "id" schema
+        <$> smQualifiedId .= field "qualified_id" schema
+        <* smId .= optional (field "id" schema)
         <*> smConvRoleName
-          .= field "conversation_role" schema
-
-instance ToJSON SimpleMember where
-  toJSON m =
-    A.object
-      [ "id" A..= smId m,
-        "conversation_role" A..= smConvRoleName m
-      ]
-
-instance FromJSON SimpleMember where
-  parseJSON = A.withObject "simple member object" $ \o ->
-    SimpleMember
-      <$> o A..: "id"
-      <*> o A..:? "conversation_role" A..!= roleNameWireAdmin
+          .= (field "conversation_role" schema <|> pure roleNameWireAdmin)
 
 data Connect = Connect
   { cRecipient :: UserId,
@@ -545,8 +530,10 @@ eventObjectSchema :: ObjectSchema SwaggerDoc Event
 eventObjectSchema =
   mk
     <$> (evtType &&& evtData) .= taggedEventDataSchema
-    <*> evtConv .= field "conversation" schema
-    <*> evtFrom .= field "from" schema
+    <* (qUnqualified . evtConv) .= optional (field "conversation" schema)
+    <*> evtConv .= field "qualified_conversation" schema
+    <* (qUnqualified . evtFrom) .= optional (field "from" schema)
+    <*> evtFrom .= field "qualified_from" schema
     <*> (toUTCTimeMillis . evtTime) .= field "time" (fromUTCTimeMillis <$> schema)
   where
     mk (ty, d) cid uid tm = Event ty cid uid tm d