SQSERVICES 1011 Servantify Galley/Team API

changelog.d/5-internal/pr-2008

@@ -0,0 +1 @@
+Servantify Galley Teams API. (#2008)

libs/galley-types/src/Galley/Types/Teams.hs

@@ -65,16 +65,17 @@ module Galley.Types.Teams
     teamListHasMore,
     TeamMember,
     userId,
+    nUserId,
     permissions,
+    nPermissions,
     invitation,
+    nInvitation,
     legalHoldStatus,
-    teamMemberJson,
     TeamMemberList,
     ListType (..),
     newTeamMemberList,
     teamMembers,
     teamMemberListType,
-    teamMemberListJson,
     TeamConversation,
     newTeamConversation,
     conversationId,
@@ -105,8 +106,6 @@ module Galley.Types.Teams
     newTeamIconKey,
     newTeamMembers,
     NewTeamMember,
-    newNewTeamMember,
-    ntmNewTeamMember,
     Event,
     newEvent,
     eventType,

libs/schema-profunctor/src/Data/Schema.hs

@@ -500,6 +500,9 @@ instance With Text where
 instance With Integer where
   with _ = (A.parseJSON >=>)
 
+instance With Bool where
+  with = A.withBool
+
 -- | A schema for a single value of an enumeration.
 element ::
   forall a b.
@@ -766,6 +769,9 @@ instance HasEnum Text NamedSwaggerDoc where
 instance HasEnum Integer NamedSwaggerDoc where
   mkEnum = mkSwaggerEnum S.SwaggerInteger
 
+instance HasEnum Bool NamedSwaggerDoc where
+  mkEnum = mkSwaggerEnum S.SwaggerBoolean
+
 mkSwaggerEnum ::
   S.SwaggerType 'S.SwaggerKindSchema ->
   Text ->

libs/wire-api/src/Wire/API/Routes/Public/Galley.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- This file is part of the Wire Server implementation.
@@ -43,6 +44,7 @@ import Wire.API.Routes.Public
 import Wire.API.Routes.Public.Util
 import Wire.API.Routes.QualifiedCapture
 import Wire.API.ServantProto (Proto, RawProto)
+import Wire.API.Team
 import Wire.API.Team.Conversation
 import Wire.API.Team.Feature
 
@@ -705,7 +707,25 @@ data Api routes = Api
         :- FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages,
     featureConfigGuestLinksGet ::
       routes
-        :- FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks
+        :- FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks,
+    -- teams
+    createNonBindingTeam ::
+      routes
+        :- Summary "Create a new non binding team"
+        :> ZUser
+        :> ZConn
+        :> CanThrow NotConnected
+        :> "teams"
+        :> ReqBody '[Servant.JSON] NonBindingNewTeam
+        :> MultiVerb
+             'POST
+             '[JSON]
+             '[ WithHeaders
+                  '[DescHeader "Location" "Team ID" TeamId]
+                  TeamId
+                  (RespondEmpty 201 "Team ID as `Location` header value")
+              ]
+             TeamId
   }
   deriving (Generic)
 

libs/wire-api/src/Wire/API/Team.hs

@@ -46,7 +46,6 @@ module Wire.API.Team
     newTeamIcon,
     newTeamIconKey,
     newTeamMembers,
-    newTeamJson,
 
     -- * TeamUpdateData
     TeamUpdateData (..),
@@ -71,12 +70,14 @@ module Wire.API.Team
 where
 
 import Control.Lens (makeLenses)
-import Data.Aeson
-import Data.Aeson.Types (Pair)
+import Data.Aeson (FromJSON, ToJSON, Value (..))
+import Data.Aeson.Types (Parser)
 import Data.Id (TeamId, UserId)
-import Data.Json.Util
 import Data.Misc (PlainTextPassword (..))
 import Data.Range
+import Data.Schema
+import Data.Singletons (sing)
+import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
 import Imports
 import Test.QuickCheck.Gen (suchThat)
@@ -96,9 +97,10 @@ data Team = Team
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform Team)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Team)
 
 newTeam :: TeamId -> UserId -> Text -> Text -> TeamBinding -> Team
-newTeam tid uid nme ico bnd = Team tid uid nme ico Nothing bnd
+newTeam tid uid nme ico = Team tid uid nme ico Nothing
 
 modelTeam :: Doc.Model
 modelTeam = Doc.defineModel "Team" $ do
@@ -117,41 +119,28 @@ modelTeam = Doc.defineModel "Team" $ do
   Doc.property "binding" Doc.bool' $
     Doc.description "user binding team"
 
-instance ToJSON Team where
-  toJSON t =
-    object $
-      "id" .= _teamId t
-        # "creator" .= _teamCreator t
-        # "name" .= _teamName t
-        # "icon" .= _teamIcon t
-        # "icon_key" .= _teamIconKey t
-        # "binding" .= _teamBinding t
-        # []
-
-instance FromJSON Team where
-  parseJSON = withObject "team" $ \o -> do
-    Team
-      <$> o .: "id"
-      <*> o .: "creator"
-      <*> o .: "name"
-      <*> o .: "icon"
-      <*> o .:? "icon_key"
-      <*> o .:? "binding" .!= NonBinding
+instance ToSchema Team where
+  schema =
+    object "Team" $
+      Team
+        <$> _teamId .= field "id" schema
+        <*> _teamCreator .= field "creator" schema
+        <*> _teamName .= field "name" schema
+        <*> _teamIcon .= field "icon" schema
+        <*> _teamIconKey .= maybe_ (optField "icon_key" schema)
+        <*> _teamBinding .= (fromMaybe Binding <$> optField "binding" schema)
 
 data TeamBinding
   = Binding
   | NonBinding
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform TeamBinding)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamBinding)
 
-instance ToJSON TeamBinding where
-  toJSON Binding = Bool True
-  toJSON NonBinding = Bool False
-
-instance FromJSON TeamBinding where
-  parseJSON (Bool True) = pure Binding
-  parseJSON (Bool False) = pure NonBinding
-  parseJSON other = fail $ "Unknown binding type: " <> show other
+instance ToSchema TeamBinding where
+  schema =
+    enum @Bool "TeamBinding" $
+      mconcat [element True Binding, element False NonBinding]
 
 --------------------------------------------------------------------------------
 -- TeamList
@@ -162,6 +151,7 @@ data TeamList = TeamList
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform TeamList)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamList)
 
 newTeamList :: [Team] -> Bool -> TeamList
 newTeamList = TeamList
@@ -174,24 +164,18 @@ modelTeamList = Doc.defineModel "TeamList" $ do
   Doc.property "has_more" Doc.bool' $
     Doc.description "if more teams are available"
 
-instance ToJSON TeamList where
-  toJSON t =
-    object $
-      "teams" .= _teamListTeams t
-        # "has_more" .= _teamListHasMore t
-        # []
-
-instance FromJSON TeamList where
-  parseJSON = withObject "teamlist" $ \o -> do
-    TeamList
-      <$> o .: "teams"
-      <*> o .: "has_more"
+instance ToSchema TeamList where
+  schema =
+    object "TeamList" $
+      TeamList <$> _teamListTeams .= field "teams" (array schema)
+        <*> _teamListHasMore .= field "has_more" schema
 
 --------------------------------------------------------------------------------
 -- NewTeam
 
 newtype BindingNewTeam = BindingNewTeam (NewTeam ())
   deriving stock (Eq, Show, Generic)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema BindingNewTeam)
 
 modelNewBindingTeam :: Doc.Model
 modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do
@@ -204,17 +188,13 @@ modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do
     Doc.description "team icon asset key"
     Doc.optional
 
-instance ToJSON BindingNewTeam where
-  toJSON (BindingNewTeam t) = object $ newTeamJson t
-
-newTeamJson :: NewTeam a -> [Pair]
-newTeamJson (NewTeam n i ik _) =
-  "name" .= fromRange n
-    # "icon" .= fromRange i
-    # "icon_key" .= (fromRange <$> ik)
-    # []
+instance ToSchema BindingNewTeam where
+  schema = BindingNewTeam <$> unwrap .= newTeamSchema "BindingNewTeam" sch
+    where
+      unwrap (BindingNewTeam nt) = nt
 
-deriving newtype instance FromJSON BindingNewTeam
+      sch :: ValueSchema SwaggerDoc ()
+      sch = null_
 
 -- FUTUREWORK: since new team members do not get serialized, we zero them here.
 -- it may be worth looking into how this can be solved in the types.
@@ -227,6 +207,15 @@ instance Arbitrary BindingNewTeam where
 -- | FUTUREWORK: this is dead code!  remove!
 newtype NonBindingNewTeam = NonBindingNewTeam (NewTeam (Range 1 127 [TeamMember]))
   deriving stock (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NonBindingNewTeam)
+
+instance ToSchema NonBindingNewTeam where
+  schema = NonBindingNewTeam <$> unwrap .= newTeamSchema "NonBindingNewTeam" sch
+    where
+      unwrap (NonBindingNewTeam nt) = nt
+
+      sch :: ValueSchema SwaggerDoc (Range 1 127 [TeamMember])
+      sch = fromRange .= rangedSchema sing sing (array schema)
 
 modelNewNonBindingTeam :: Doc.Model
 modelNewNonBindingTeam = Doc.defineModel "newNonBindingTeam" $ do
@@ -242,14 +231,6 @@ modelNewNonBindingTeam = Doc.defineModel "newNonBindingTeam" $ do
     Doc.description "initial team member ids (between 1 and 127)"
     Doc.optional
 
-instance ToJSON NonBindingNewTeam where
-  toJSON (NonBindingNewTeam t) =
-    object $
-      "members" .= (fromRange <$> _newTeamMembers t)
-        # newTeamJson t
-
-deriving newtype instance FromJSON NonBindingNewTeam
-
 data NewTeam a = NewTeam
   { _newTeamName :: Range 1 256 Text,
     _newTeamIcon :: Range 1 256 Text,
@@ -262,17 +243,14 @@ data NewTeam a = NewTeam
 newNewTeam :: Range 1 256 Text -> Range 1 256 Text -> NewTeam a
 newNewTeam nme ico = NewTeam nme ico Nothing Nothing
 
-instance (FromJSON a) => FromJSON (NewTeam a) where
-  parseJSON = withObject "new-team" $ \o -> do
-    name <- o .: "name"
-    icon <- o .: "icon"
-    key <- o .:? "icon_key"
-    mems <- o .:? "members"
-    either fail pure $
-      NewTeam <$> checkedEitherMsg "name" name
-        <*> checkedEitherMsg "icon" icon
-        <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") key
-        <*> pure mems
+newTeamSchema :: HasSchemaRef d => Text -> ValueSchema d a -> ValueSchema NamedSwaggerDoc (NewTeam a)
+newTeamSchema name sch =
+  object name $
+    NewTeam
+      <$> _newTeamName .= field "name" schema
+      <*> _newTeamIcon .= field "icon" schema
+      <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema)
+      <*> _newTeamMembers .= maybe_ (optField "members" sch)
 
 --------------------------------------------------------------------------------
 -- TeamUpdateData
@@ -283,6 +261,7 @@ data TeamUpdateData = TeamUpdateData
     _iconKeyUpdate :: Maybe (Range 1 256 Text)
   }
   deriving stock (Eq, Show, Generic)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamUpdateData)
 
 instance Arbitrary TeamUpdateData where
   arbitrary = arb `suchThat` valid
@@ -307,25 +286,21 @@ modelUpdateData = Doc.defineModel "TeamUpdateData" $ do
 newTeamUpdateData :: TeamUpdateData
 newTeamUpdateData = TeamUpdateData Nothing Nothing Nothing
 
-instance ToJSON TeamUpdateData where
-  toJSON u =
-    object $
-      "name" .= _nameUpdate u
-        # "icon" .= _iconUpdate u
-        # "icon_key" .= _iconKeyUpdate u
-        # []
-
-instance FromJSON TeamUpdateData where
-  parseJSON = withObject "team update data" $ \o -> do
-    name <- o .:? "name"
-    icon <- o .:? "icon"
-    icon_key <- o .:? "icon_key"
-    when (isNothing name && isNothing icon && isNothing icon_key) $
-      fail "TeamUpdateData: no update data specified"
-    either fail pure $
-      TeamUpdateData <$> maybe (pure Nothing) (fmap Just . checkedEitherMsg "name") name
-        <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon") icon
-        <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") icon_key
+validateTeamUpdateData :: TeamUpdateData -> Parser TeamUpdateData
+validateTeamUpdateData u =
+  when
+    (isNothing (_nameUpdate u) && isNothing (_iconUpdate u) && isNothing (_iconKeyUpdate u))
+    (fail "TeamUpdateData: no update data specified")
+    $> u
+
+instance ToSchema TeamUpdateData where
+  schema =
+    (`withParser` validateTeamUpdateData)
+      . object "TeamUpdateData"
+      $ TeamUpdateData
+        <$> _nameUpdate .= maybe_ (optField "name" schema)
+        <*> _iconUpdate .= maybe_ (optField "icon" schema)
+        <*> _iconKeyUpdate .= maybe_ (optField "icon_key" schema)
 
 --------------------------------------------------------------------------------
 -- TeamDeleteData
@@ -335,6 +310,7 @@ newtype TeamDeleteData = TeamDeleteData
   }
   deriving stock (Eq, Show)
   deriving newtype (Arbitrary)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema TeamDeleteData)
 
 newTeamDeleteData :: Maybe PlainTextPassword -> TeamDeleteData
 newTeamDeleteData = TeamDeleteData
@@ -346,15 +322,10 @@ modelTeamDelete = Doc.defineModel "teamDeleteData" $ do
   Doc.property "password" Doc.string' $
     Doc.description "The account password to authorise the deletion."
 
-instance FromJSON TeamDeleteData where
-  parseJSON = withObject "team-delete-data" $ \o ->
-    TeamDeleteData <$> o .: "password"
-
-instance ToJSON TeamDeleteData where
-  toJSON tdd =
-    object
-      [ "password" .= _tdAuthPassword tdd
-      ]
+instance ToSchema TeamDeleteData where
+  schema =
+    object "TeamDeleteData" $
+      TeamDeleteData <$> _tdAuthPassword .= optField "password" (maybeWithDefault Null schema)
 
 makeLenses ''Team
 makeLenses ''TeamList