Lock/Unlock Payment Status for Self Deleting Messages

cabal.project.freeze

@@ -1702,6 +1702,7 @@ constraints: any.AC-Angle ==1.0,
              any.polynomials-bernstein ==1.1.2,
              any.polyparse ==1.13,
              any.polysemy ==1.6.0.0,
+             any.polysemy-check ==0.8.1.0,
              any.polysemy-mocks ==0.1.0.0,
              any.polysemy-plugin ==0.2.5.2,
              any.pooled-io ==0.0.2.2,

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

@@ -212,11 +212,11 @@ data FeatureFlags = FeatureFlags
   { _flagSSO :: !FeatureSSO,
     _flagLegalHold :: !FeatureLegalHold,
     _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility,
-    _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)),
-    _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains),
-    _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)),
-    _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)),
-    _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages))
+    _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureAppLock)),
+    _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureClassifiedDomains),
+    _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureFileSharing)),
+    _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureConferenceCalling)),
+    _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithPaymentStatus 'TeamFeatureSelfDeletingMessages))
   }
   deriving (Eq, Show, Generic)
 

libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs

@@ -66,7 +66,7 @@ type GetAccountFeatureConfig =
     :> Capture "uid" UserId
     :> "features"
     :> "conferenceCalling"
-    :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling)
+    :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithPaymentStatus 'ApiFt.TeamFeatureConferenceCalling)
 
 type PutAccountFeatureConfig =
   Summary
@@ -75,7 +75,7 @@ type PutAccountFeatureConfig =
     :> Capture "uid" UserId
     :> "features"
     :> "conferenceCalling"
-    :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.TeamFeatureConferenceCalling)
+    :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutPaymentStatus 'ApiFt.TeamFeatureConferenceCalling)
     :> Put '[Servant.JSON] NoContent
 
 type DeleteAccountFeatureConfig =

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

@@ -623,7 +623,7 @@ data Api routes = Api
         :- FeatureStatusPut 'TeamFeatureSearchVisibility,
     teamFeatureStatusSearchVisibilityDeprecatedGet ::
       routes
-        :- FeatureStatusDeprecatedGet 'TeamFeatureSearchVisibility,
+        :- FeatureStatusDeprecatedGet 'WithoutPaymentStatus 'TeamFeatureSearchVisibility,
     teamFeatureStatusSearchVisibilityDeprecatedPut ::
       routes
         :- FeatureStatusDeprecatedPut 'TeamFeatureSearchVisibility,
@@ -632,13 +632,13 @@ data Api routes = Api
         :- FeatureStatusGet 'TeamFeatureValidateSAMLEmails,
     teamFeatureStatusValidateSAMLEmailsDeprecatedGet ::
       routes
-        :- FeatureStatusDeprecatedGet 'TeamFeatureValidateSAMLEmails,
+        :- FeatureStatusDeprecatedGet 'WithoutPaymentStatus 'TeamFeatureValidateSAMLEmails,
     teamFeatureStatusDigitalSignaturesGet ::
       routes
         :- FeatureStatusGet 'TeamFeatureDigitalSignatures,
     teamFeatureStatusDigitalSignaturesDeprecatedGet ::
       routes
-        :- FeatureStatusDeprecatedGet 'TeamFeatureDigitalSignatures,
+        :- FeatureStatusDeprecatedGet 'WithoutPaymentStatus 'TeamFeatureDigitalSignatures,
     teamFeatureStatusAppLockGet ::
       routes
         :- FeatureStatusGet 'TeamFeatureAppLock,
@@ -668,34 +668,34 @@ data Api routes = Api
         :- AllFeatureConfigsGet,
     featureConfigLegalHoldGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureLegalHold,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureLegalHold,
     featureConfigSSOGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureSSO,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureSSO,
     featureConfigSearchVisibilityGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureSearchVisibility,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureSearchVisibility,
     featureConfigValidateSAMLEmailsGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureValidateSAMLEmails,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureValidateSAMLEmails,
     featureConfigDigitalSignaturesGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureDigitalSignatures,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureDigitalSignatures,
     featureConfigAppLockGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureAppLock,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureAppLock,
     featureConfigFileSharingGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureFileSharing,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureFileSharing,
     featureConfigClassifiedDomainsGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureClassifiedDomains,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureClassifiedDomains,
     featureConfigConferenceCallingGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureConferenceCalling,
+        :- FeatureConfigGet 'WithoutPaymentStatus 'TeamFeatureConferenceCalling,
     featureConfigSelfDeletingMessagesGet ::
       routes
-        :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages
+        :- FeatureConfigGet 'WithPaymentStatus 'TeamFeatureSelfDeletingMessages
   }
   deriving (Generic)
 
@@ -708,7 +708,7 @@ type FeatureStatusGet featureName =
     :> Capture "tid" TeamId
     :> "features"
     :> KnownTeamFeatureNameSymbol featureName
-    :> Get '[Servant.JSON] (TeamFeatureStatus featureName)
+    :> Get '[Servant.JSON] (TeamFeatureStatus 'WithPaymentStatus featureName)
 
 type FeatureStatusPut featureName =
   Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName))
@@ -717,18 +717,18 @@ type FeatureStatusPut featureName =
     :> Capture "tid" TeamId
     :> "features"
     :> KnownTeamFeatureNameSymbol featureName
-    :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName)
-    :> Put '[Servant.JSON] (TeamFeatureStatus featureName)
+    :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutPaymentStatus featureName)
+    :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutPaymentStatus featureName)
 
 -- | A type for a GET endpoint for a feature with a deprecated path
-type FeatureStatusDeprecatedGet featureName =
+type FeatureStatusDeprecatedGet ps featureName =
   Summary (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName))
     :> ZUser
     :> "teams"
     :> Capture "tid" TeamId
     :> "features"
     :> DeprecatedFeatureName featureName
-    :> Get '[Servant.JSON] (TeamFeatureStatus featureName)
+    :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName)
 
 -- | A type for a PUT endpoint for a feature with a deprecated path
 type FeatureStatusDeprecatedPut featureName =
@@ -738,15 +738,15 @@ type FeatureStatusDeprecatedPut featureName =
     :> Capture "tid" TeamId
     :> "features"
     :> DeprecatedFeatureName featureName
-    :> ReqBody '[Servant.JSON] (TeamFeatureStatus featureName)
-    :> Put '[Servant.JSON] (TeamFeatureStatus featureName)
+    :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutPaymentStatus featureName)
+    :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutPaymentStatus featureName)
 
-type FeatureConfigGet featureName =
+type FeatureConfigGet ps featureName =
   Summary (AppendSymbol "Get feature config for feature " (KnownTeamFeatureNameSymbol featureName))
     :> ZUser
     :> "feature-configs"
     :> KnownTeamFeatureNameSymbol featureName
-    :> Get '[Servant.JSON] (TeamFeatureStatus featureName)
+    :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName)
 
 type AllFeatureConfigsGet =
   Summary "Get configurations of all features"

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

@@ -52,9 +52,9 @@ type PublicAPI =
 
 type InternalAPI =
   "i" :> "teams" :> Capture "tid" TeamId :> "legalhold"
-    :> Get '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold)
+    :> Get '[JSON] (TeamFeatureStatus 'WithPaymentStatus 'TeamFeatureLegalHold)
     :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold"
-      :> ReqBody '[JSON] (TeamFeatureStatus 'TeamFeatureLegalHold)
+      :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureLegalHold)
       :> Put '[] NoContent
 
 swaggerDoc :: Swagger

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

@@ -129,6 +129,7 @@ models =
     Team.Feature.modelTeamFeatureAppLockConfig,
     Team.Feature.modelTeamFeatureClassifiedDomainsConfig,
     Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig,
+    Team.Feature.modelPaymentStatus,
     Team.Invitation.modelTeamInvitation,
     Team.Invitation.modelTeamInvitationList,
     Team.Invitation.modelTeamInvitationRequest,

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

@@ -30,8 +30,12 @@ module Wire.API.Team.Feature
     KnownTeamFeatureName (..),
     TeamFeatureStatusNoConfig (..),
     TeamFeatureStatusWithConfig (..),
+    TeamFeatureStatusWithConfigAndPaymentStatus (..),
     HasDeprecatedFeatureName (..),
     AllFeatureConfigs (..),
+    PaymentStatus (..),
+    PaymentStatusValue (..),
+    IncludePaymentStatus (..),
     defaultAppLockStatus,
     defaultClassifiedDomains,
     defaultSelfDeletingMessagesStatus,
@@ -44,16 +48,19 @@ module Wire.API.Team.Feature
     modelTeamFeatureAppLockConfig,
     modelTeamFeatureClassifiedDomainsConfig,
     modelTeamFeatureSelfDeletingMessagesConfig,
+    modelTeamFeatureStatusWithConfigAndPaymentStatus,
     modelForTeamFeature,
+    modelPaymentStatus,
   )
 where
 
 import qualified Cassandra.CQL as Cass
 import Control.Lens.Combinators (dimap)
 import qualified Data.Aeson as Aeson
 import qualified Data.Attoparsec.ByteString as Parser
-import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), toByteString')
+import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), fromByteString, toByteString')
 import Data.Domain (Domain)
+import Data.Either.Extra (maybeToEither)
 import Data.Kind (Constraint)
 import Data.Schema
 import Data.String.Conversions (cs)
@@ -64,6 +71,7 @@ import qualified Data.Text.Encoding as T
 import Deriving.Aeson
 import GHC.TypeLits (Symbol)
 import Imports
+import Servant (FromHttpApiData (..))
 import Test.QuickCheck.Arbitrary (arbitrary)
 import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
 
@@ -283,19 +291,22 @@ instance Cass.Cql TeamFeatureStatusValue where
 ----------------------------------------------------------------------
 -- TeamFeatureStatus
 
-type family TeamFeatureStatus (a :: TeamFeatureName) :: * where
-  TeamFeatureStatus 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureSSO = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig
-  TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig
-  TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig
-  TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig
+data IncludePaymentStatus = WithPaymentStatus | WithoutPaymentStatus
 
-type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint
+type family TeamFeatureStatus (ps :: IncludePaymentStatus) (a :: TeamFeatureName) :: * where
+  TeamFeatureStatus _ 'TeamFeatureLegalHold = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureSSO = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureSearchVisibility = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig
+  TeamFeatureStatus _ 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig
+  TeamFeatureStatus _ 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig
+  TeamFeatureStatus _ 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig
+  TeamFeatureStatus 'WithoutPaymentStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig
+  TeamFeatureStatus 'WithPaymentStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfigAndPaymentStatus TeamFeatureSelfDeletingMessagesConfig
+
+type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus 'WithoutPaymentStatus a ~ TeamFeatureStatusNoConfig) :: Constraint
 
 -- if you add a new constructor here, don't forget to add it to the swagger (1.2) docs in "Wire.API.Swagger"!
 modelForTeamFeature :: TeamFeatureName -> Doc.Model
@@ -360,6 +371,32 @@ instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfig cfg) where
         <$> tfwcStatus .= field "status" schema
         <*> tfwcConfig .= field "config" schema
 
+data TeamFeatureStatusWithConfigAndPaymentStatus (cfg :: *) = TeamFeatureStatusWithConfigAndPaymentStatus
+  { tfwcapsStatus :: TeamFeatureStatusValue,
+    tfwcapsConfig :: cfg,
+    tfwcapsPaymentStatus :: PaymentStatusValue
+  }
+  deriving stock (Eq, Show, Generic, Typeable)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (TeamFeatureStatusWithConfigAndPaymentStatus cfg))
+
+instance Arbitrary cfg => Arbitrary (TeamFeatureStatusWithConfigAndPaymentStatus cfg) where
+  arbitrary = TeamFeatureStatusWithConfigAndPaymentStatus <$> arbitrary <*> arbitrary <*> arbitrary
+
+modelTeamFeatureStatusWithConfigAndPaymentStatus :: TeamFeatureName -> Doc.Model -> Doc.Model
+modelTeamFeatureStatusWithConfigAndPaymentStatus name cfgModel = Doc.defineModel (cs $ show name) $ do
+  Doc.description $ "Status and config of " <> cs (show name)
+  Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "status"
+  Doc.property "config" (Doc.ref cfgModel) $ Doc.description "config"
+  Doc.property "paymentStatus" typePaymentStatusValue $ Doc.description "config"
+
+instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndPaymentStatus cfg) where
+  schema =
+    object "TeamFeatureStatusWithConfigAndPaymentStatus" $
+      TeamFeatureStatusWithConfigAndPaymentStatus
+        <$> tfwcapsStatus .= field "status" schema
+        <*> tfwcapsConfig .= field "config" schema
+        <*> tfwcapsPaymentStatus .= field "paymentStatus" schema
+
 ----------------------------------------------------------------------
 -- TeamFeatureClassifiedDomainsConfig
 
@@ -383,7 +420,10 @@ modelTeamFeatureClassifiedDomainsConfig =
     Doc.property "domains" (Doc.array Doc.string') $ Doc.description "domains"
 
 defaultClassifiedDomains :: TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig
-defaultClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureDisabled (TeamFeatureClassifiedDomainsConfig [])
+defaultClassifiedDomains =
+  TeamFeatureStatusWithConfig
+    TeamFeatureDisabled
+    (TeamFeatureClassifiedDomainsConfig [])
 
 ----------------------------------------------------------------------
 -- TeamFeatureAppLockConfig
@@ -445,11 +485,82 @@ modelTeamFeatureSelfDeletingMessagesConfig =
   Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do
     Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)"
 
-defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig
+defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfigAndPaymentStatus TeamFeatureSelfDeletingMessagesConfig
 defaultSelfDeletingMessagesStatus =
-  TeamFeatureStatusWithConfig
+  TeamFeatureStatusWithConfigAndPaymentStatus
     TeamFeatureEnabled
     (TeamFeatureSelfDeletingMessagesConfig 0)
+    PaymentLocked
+
+----------------------------------------------------------------------
+-- PaymentStatus
+
+instance FromHttpApiData PaymentStatusValue where
+  parseUrlPiece = maybeToEither "Invalid payment status" . fromByteString . cs
+
+data PaymentStatusValue = PaymentLocked | PaymentUnlocked
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform PaymentStatusValue)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema PaymentStatusValue)
+
+newtype PaymentStatus = PaymentStatus
+  { paymentStatus :: PaymentStatusValue
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema PaymentStatus)
+  deriving (Arbitrary) via (GenericUniform PaymentStatus)
+
+instance ToSchema PaymentStatus where
+  schema =
+    object "PaymentStatus" $
+      PaymentStatus
+        <$> paymentStatus .= field "paymentStatus" schema
+
+modelPaymentStatus :: Doc.Model
+modelPaymentStatus =
+  Doc.defineModel "PaymentStatus" $ do
+    Doc.property "paymentStatus" typePaymentStatusValue $ Doc.description ""
+
+typePaymentStatusValue :: Doc.DataType
+typePaymentStatusValue =
+  Doc.string $
+    Doc.enum
+      [ "locked",
+        "unlocked"
+      ]
+
+instance ToSchema PaymentStatusValue where
+  schema =
+    enum @Text "PaymentStatusValue" $
+      mconcat
+        [ element "locked" PaymentLocked,
+          element "unlocked" PaymentUnlocked
+        ]
+
+instance ToByteString PaymentStatusValue where
+  builder PaymentLocked = "locked"
+  builder PaymentUnlocked = "unlocked"
+
+instance FromByteString PaymentStatusValue where
+  parser =
+    Parser.takeByteString >>= \b ->
+      case T.decodeUtf8' b of
+        Right "locked" -> pure PaymentLocked
+        Right "unlocked" -> pure PaymentUnlocked
+        Right t -> fail $ "Invalid PaymentStatusValue: " <> T.unpack t
+        Left e -> fail $ "Invalid PaymentStatusValue: " <> show e
+
+instance Cass.Cql PaymentStatusValue where
+  ctype = Cass.Tagged Cass.IntColumn
+
+  fromCql (Cass.CqlInt n) = case n of
+    0 -> pure PaymentLocked
+    1 -> pure PaymentUnlocked
+    _ -> Left "fromCql: Invalid PaymentStatusValue"
+  fromCql _ = Left "fromCql: PaymentStatusValue: CqlInt expected"
+
+  toCql PaymentLocked = Cass.CqlInt 0
+  toCql PaymentUnlocked = Cass.CqlInt 1
 
 ----------------------------------------------------------------------
 -- internal