-
Notifications
You must be signed in to change notification settings - Fork 334
Expand file tree
/
Copy pathFeatureFlags.hs
More file actions
533 lines (436 loc) · 21.7 KB
/
FeatureFlags.hs
File metadata and controls
533 lines (436 loc) · 21.7 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
module Wire.API.Team.FeatureFlags
( GetFeatureDefaults (..),
FeatureDefaults (..),
FeatureFlags,
FanoutLimit,
featureDefaults,
defaultFanoutLimit,
currentFanoutLimit,
notTeamMember,
findTeamMember,
isTeamMember,
isTeamOwner,
canSeePermsOf,
)
where
import Control.Lens (view)
import Data.Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.Types qualified as A
import Data.ByteString (toStrict)
import Data.ByteString.UTF8 qualified as UTF8
import Data.Default
import Data.Id (UserId)
import Data.OpenApi qualified as S
import Data.Range (Range, fromRange, toRange, unsafeRange)
import Data.SOP
import Data.Schema
import Data.Set qualified as Set
import Imports
import Wire.API.Team.Feature
import Wire.API.Team.Member
import Wire.API.Team.Permission
type FanoutLimit = Range 1 HardTruncationLimit Int32
defaultFanoutLimit :: FanoutLimit
defaultFanoutLimit = toRange (Proxy @HardTruncationLimit)
currentFanoutLimit :: Word32 -> Maybe FanoutLimit -> FanoutLimit
currentFanoutLimit maxTeamSize maxFanoutSize =
let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit maxFanoutSize
maxSize = fromIntegral maxTeamSize
in unsafeRange (min maxSize optFanoutLimit)
-- | Used to extract the feature config type out of 'FeatureDefaults' or
-- related types.
type family ConfigOf a
type instance ConfigOf (FeatureDefaults cfg) = cfg
-- | Convert a feature default value to an actual 'LockableFeature'.
class GetFeatureDefaults a where
featureDefaults1 :: a -> LockableFeature (ConfigOf a)
type instance ConfigOf (Feature cfg) = cfg
instance (IsFeatureConfig cfg) => GetFeatureDefaults (Feature cfg) where
featureDefaults1 = withLockStatus (def @(LockableFeature cfg)).lockStatus
-- | Some features do not have a configured default value, so this takes it
-- wholly from the 'Default' instance.
newtype FixedDefaults cfg = FixedDefaults (FeatureDefaults cfg)
type instance ConfigOf (FixedDefaults cfg) = cfg
instance (IsFeatureConfig cfg) => GetFeatureDefaults (FixedDefaults cfg) where
featureDefaults1 _ = def
type instance ConfigOf (LockableFeature cfg) = cfg
instance GetFeatureDefaults (LockableFeature cfg) where
featureDefaults1 = id
data family FeatureDefaults cfg
data instance FeatureDefaults LegalholdConfig
= FeatureLegalHoldDisabledPermanently
| FeatureLegalHoldDisabledByDefault
| FeatureLegalHoldWhitelistTeamsAndImplicitConsent
deriving stock (Eq, Ord, Show)
deriving (ParseFeatureDefaults) via RequiredField LegalholdConfig
deriving (GetFeatureDefaults) via FixedDefaults LegalholdConfig
deriving (S.ToSchema) via Schema (FeatureDefaults LegalholdConfig)
instance Default (FeatureDefaults LegalholdConfig) where
def = FeatureLegalHoldDisabledByDefault
instance ToSchema (FeatureDefaults LegalholdConfig) where
schema = mkSchema d r w
where
d = pure $ S.NamedSchema (Just "FeatureDefaults LegalholdConfig") mempty
r = parseJSON
w = Just . toJSON
instance FromJSON (FeatureDefaults LegalholdConfig) where
parseJSON (String "disabled-permanently") = pure $ FeatureLegalHoldDisabledPermanently
parseJSON (String "disabled-by-default") = pure $ FeatureLegalHoldDisabledByDefault
parseJSON (String "whitelist-teams-and-implicit-consent") = pure FeatureLegalHoldWhitelistTeamsAndImplicitConsent
parseJSON bad = fail $ "FeatureLegalHold: " <> (UTF8.toString . toStrict . encode $ bad)
instance ToJSON (FeatureDefaults LegalholdConfig) where
toJSON =
\case
FeatureLegalHoldDisabledPermanently -> String "disabled-permanently"
FeatureLegalHoldDisabledByDefault -> String "disabled-by-default"
FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> String "whitelist-teams-and-implicit-consent"
data instance FeatureDefaults SSOConfig
= FeatureSSOEnabledByDefault
| FeatureSSODisabledByDefault
deriving stock (Eq, Ord, Show)
deriving (ParseFeatureDefaults) via RequiredField SSOConfig
instance Default (FeatureDefaults SSOConfig) where
def = FeatureSSOEnabledByDefault
instance FromJSON (FeatureDefaults SSOConfig) where
parseJSON (String "enabled-by-default") = pure FeatureSSOEnabledByDefault
parseJSON (String "disabled-by-default") = pure FeatureSSODisabledByDefault
parseJSON bad = fail $ "FeatureSSO: " <> (UTF8.toString . toStrict . encode $ bad)
instance ToJSON (FeatureDefaults SSOConfig) where
toJSON =
\case
FeatureSSOEnabledByDefault -> String "enabled-by-default"
FeatureSSODisabledByDefault -> String "disabled-by-default"
instance GetFeatureDefaults (FeatureDefaults SSOConfig) where
featureDefaults1 flag =
def
{ status = case flag of
FeatureSSOEnabledByDefault -> FeatureStatusEnabled
FeatureSSODisabledByDefault -> FeatureStatusDisabled
}
-- | Default value for all teams that have not enabled or disabled this feature explicitly.
data instance FeatureDefaults SearchVisibilityAvailableConfig
= FeatureTeamSearchVisibilityAvailableByDefault
| FeatureTeamSearchVisibilityUnavailableByDefault
deriving stock (Eq, Ord, Show)
instance Default (FeatureDefaults SearchVisibilityAvailableConfig) where
def = FeatureTeamSearchVisibilityAvailableByDefault
instance ParseFeatureDefaults (FeatureDefaults SearchVisibilityAvailableConfig) where
parseFeatureDefaults obj = obj .: "teamSearchVisibility"
instance FromJSON (FeatureDefaults SearchVisibilityAvailableConfig) where
parseJSON (String "enabled-by-default") = pure FeatureTeamSearchVisibilityAvailableByDefault
parseJSON (String "disabled-by-default") = pure FeatureTeamSearchVisibilityUnavailableByDefault
parseJSON bad = fail $ "FeatureSearchVisibility: " <> (UTF8.toString . toStrict . encode $ bad)
instance ToJSON (FeatureDefaults SearchVisibilityAvailableConfig) where
toJSON =
\case
FeatureTeamSearchVisibilityAvailableByDefault -> String "enabled-by-default"
FeatureTeamSearchVisibilityUnavailableByDefault -> String "disabled-by-default"
instance GetFeatureDefaults (FeatureDefaults SearchVisibilityAvailableConfig) where
featureDefaults1 flag =
def
{ status = case flag of
FeatureTeamSearchVisibilityAvailableByDefault -> FeatureStatusEnabled
FeatureTeamSearchVisibilityUnavailableByDefault -> FeatureStatusDisabled
}
newtype instance FeatureDefaults SearchVisibilityInboundConfig
= SearchVisibilityInboundDefaults (Feature SearchVisibilityInboundConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (Feature SearchVisibilityInboundConfig)
deriving (ParseFeatureDefaults) via OptionalField SearchVisibilityInboundConfig
newtype instance FeatureDefaults RequireExternalEmailVerificationConfig
= RequireExternalEmailVerificationDefaults (Feature RequireExternalEmailVerificationConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (Feature RequireExternalEmailVerificationConfig)
instance ParseFeatureDefaults (FeatureDefaults RequireExternalEmailVerificationConfig) where
parseFeatureDefaults obj =
do
-- Accept the legacy typo in config input for backward compatibility,
-- but prefer the canonical feature key when both are present.
mCanonical :: Maybe (FeatureDefaults RequireExternalEmailVerificationConfig) <- obj .:? featureKey @RequireExternalEmailVerificationConfig
mLegacy :: Maybe (FeatureDefaults RequireExternalEmailVerificationConfig) <- obj .:? "validateSAMLEmails"
pure $ fromMaybe def (mCanonical <|> mLegacy)
data instance FeatureDefaults DigitalSignaturesConfig = DigitalSignaturesDefaults
deriving stock (Eq, Show)
deriving (GetFeatureDefaults) via FixedDefaults DigitalSignaturesConfig
instance Default (FeatureDefaults DigitalSignaturesConfig) where
def = DigitalSignaturesDefaults
instance ParseFeatureDefaults (FeatureDefaults DigitalSignaturesConfig) where
parseFeatureDefaults _ = pure DigitalSignaturesDefaults
instance ToJSON (FeatureDefaults DigitalSignaturesConfig) where
toJSON =
\case
DigitalSignaturesDefaults -> String "digital-signatures-defaults"
newtype instance FeatureDefaults AppLockConfig
= AppLockDefaults (Feature AppLockConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (Feature AppLockConfig)
deriving (ParseFeatureDefaults) via OptionalField AppLockConfig
newtype instance FeatureDefaults FileSharingConfig
= FileSharingDefaults (LockableFeature FileSharingConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature FileSharingConfig)
deriving (ParseFeatureDefaults) via OptionalField FileSharingConfig
newtype instance FeatureDefaults ClassifiedDomainsConfig
= ClassifiedDomainsDefaults (Feature ClassifiedDomainsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, FromJSON, ToJSON)
deriving (ParseFeatureDefaults) via OptionalField ClassifiedDomainsConfig
deriving (GetFeatureDefaults) via Feature ClassifiedDomainsConfig
newtype instance FeatureDefaults ConferenceCallingConfig
= ConferenceCallingDefaults (LockableFeature ConferenceCallingConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature ConferenceCallingConfig)
deriving (ParseFeatureDefaults) via OptionalField ConferenceCallingConfig
newtype instance FeatureDefaults SelfDeletingMessagesConfig
= SelfDeletingMessagesDefaults (LockableFeature SelfDeletingMessagesConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature SelfDeletingMessagesConfig)
deriving (ParseFeatureDefaults) via OptionalField SelfDeletingMessagesConfig
newtype instance FeatureDefaults GuestLinksConfig
= GuestLinksDefaults (LockableFeature GuestLinksConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature GuestLinksConfig)
deriving (ParseFeatureDefaults) via OptionalField GuestLinksConfig
newtype instance FeatureDefaults SndFactorPasswordChallengeConfig
= SndFactorPasswordChallengeDefaults (LockableFeature SndFactorPasswordChallengeConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature SndFactorPasswordChallengeConfig)
deriving (ParseFeatureDefaults) via OptionalField SndFactorPasswordChallengeConfig
newtype instance FeatureDefaults MLSConfig
= MLSDefaults (LockableFeature MLSConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature MLSConfig)
deriving (ParseFeatureDefaults) via OptionalField MLSConfig
newtype instance FeatureDefaults ChannelsConfig
= ChannelsDefaults (LockableFeature ChannelsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature ChannelsConfig)
deriving (ParseFeatureDefaults) via OptionalField ChannelsConfig
newtype instance FeatureDefaults CellsInternalConfig
= CellsInternalDefaults (LockableFeature CellsInternalConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature CellsInternalConfig)
deriving (ParseFeatureDefaults) via OptionalField CellsInternalConfig
data instance FeatureDefaults ExposeInvitationURLsToTeamAdminConfig
= ExposeInvitationURLsToTeamAdminDefaults
deriving stock (Eq, Show)
deriving (GetFeatureDefaults) via FixedDefaults ExposeInvitationURLsToTeamAdminConfig
instance Default (FeatureDefaults ExposeInvitationURLsToTeamAdminConfig) where
def = ExposeInvitationURLsToTeamAdminDefaults
instance ParseFeatureDefaults (FeatureDefaults ExposeInvitationURLsToTeamAdminConfig) where
parseFeatureDefaults _ = pure ExposeInvitationURLsToTeamAdminDefaults
instance ToJSON (FeatureDefaults ExposeInvitationURLsToTeamAdminConfig) where
toJSON =
\case
ExposeInvitationURLsToTeamAdminDefaults -> String "expose-invitation-urls-to-team-admin-defaults"
newtype instance FeatureDefaults OutlookCalIntegrationConfig
= OutlookCalIntegrationDefaults (LockableFeature OutlookCalIntegrationConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature OutlookCalIntegrationConfig)
deriving (ParseFeatureDefaults) via OptionalField OutlookCalIntegrationConfig
newtype instance FeatureDefaults MlsE2EIdConfig
= MlsE2EIdDefaults (LockableFeature MlsE2EIdConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature MlsE2EIdConfig)
deriving (ParseFeatureDefaults) via OptionalField MlsE2EIdConfig
newtype instance FeatureDefaults MlsMigrationConfig
= MlsMigrationDefaults (LockableFeature MlsMigrationConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature MlsMigrationConfig)
deriving (ParseFeatureDefaults) via OptionalField MlsMigrationConfig
newtype instance FeatureDefaults EnforceFileDownloadLocationConfig
= EnforceFileDownloadLocationDefaults (LockableFeature EnforceFileDownloadLocationConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature EnforceFileDownloadLocationConfig)
deriving (ParseFeatureDefaults) via OptionalField EnforceFileDownloadLocationConfig
newtype instance FeatureDefaults LimitedEventFanoutConfig
= LimitedEventFanoutDefaults (Feature LimitedEventFanoutConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (Feature LimitedEventFanoutConfig)
deriving (ParseFeatureDefaults) via OptionalField LimitedEventFanoutConfig
newtype instance FeatureDefaults DomainRegistrationConfig
= DomainRegistrationConfigDefaults (LockableFeature DomainRegistrationConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature DomainRegistrationConfig)
deriving (ParseFeatureDefaults) via OptionalField DomainRegistrationConfig
newtype instance FeatureDefaults CellsConfig
= CellsConfigDefaults (LockableFeature CellsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature CellsConfig)
deriving (ParseFeatureDefaults) via OptionalField CellsConfig
newtype instance FeatureDefaults AllowedGlobalOperationsConfig
= AllowedGlobalOperationsConfigDefaults (Feature AllowedGlobalOperationsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, FromJSON, ToJSON)
deriving (ParseFeatureDefaults) via OptionalField AllowedGlobalOperationsConfig
deriving (GetFeatureDefaults) via Feature AllowedGlobalOperationsConfig
newtype instance FeatureDefaults AssetAuditLogConfig
= AssetAuditLogDefaults (Feature AssetAuditLogConfig)
deriving stock (Eq, Show)
deriving newtype (Default, FromJSON, ToJSON)
deriving (ParseFeatureDefaults) via OptionalField AssetAuditLogConfig
deriving (GetFeatureDefaults) via Feature AssetAuditLogConfig
newtype instance FeatureDefaults ConsumableNotificationsConfig
= ConsumableNotificationsDefaults (LockableFeature ConsumableNotificationsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature ConsumableNotificationsConfig)
deriving (ParseFeatureDefaults) via OptionalField ConsumableNotificationsConfig
newtype instance FeatureDefaults ChatBubblesConfig
= ChatBubblesDefaults (LockableFeature ChatBubblesConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature ChatBubblesConfig)
deriving (ParseFeatureDefaults) via OptionalField ChatBubblesConfig
newtype instance FeatureDefaults AppsConfig
= AppsDefaults (LockableFeature AppsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature AppsConfig)
deriving (ParseFeatureDefaults) via OptionalField AppsConfig
newtype instance FeatureDefaults SimplifiedUserConnectionRequestQRCodeConfig
= SimplifiedUserConnectionRequestQRCodeDefaults (LockableFeature SimplifiedUserConnectionRequestQRCodeConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature SimplifiedUserConnectionRequestQRCodeConfig)
deriving (ParseFeatureDefaults) via OptionalField SimplifiedUserConnectionRequestQRCodeConfig
newtype instance FeatureDefaults StealthUsersConfig
= StealthUsersDefaults (LockableFeature StealthUsersConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature StealthUsersConfig)
deriving (ParseFeatureDefaults) via OptionalField StealthUsersConfig
newtype instance FeatureDefaults MeetingsConfig
= MeetingDefaults (LockableFeature MeetingsConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature MeetingsConfig)
deriving (ParseFeatureDefaults) via OptionalField MeetingsConfig
newtype instance FeatureDefaults MeetingsPremiumConfig
= MeetingPremiumDefaults (LockableFeature MeetingsPremiumConfig)
deriving stock (Eq, Show)
deriving newtype (Default, GetFeatureDefaults)
deriving (FromJSON, ToJSON) via Defaults (LockableFeature MeetingsPremiumConfig)
deriving (ParseFeatureDefaults) via OptionalField MeetingsPremiumConfig
featureKey :: forall cfg. (IsFeatureConfig cfg) => Key.Key
featureKey = Key.fromText $ featureName @cfg
class ParseFeatureDefaults a where
parseFeatureDefaults :: A.Object -> A.Parser a
newtype RequiredField cfg = RequiredField (FeatureDefaults cfg)
instance
(IsFeatureConfig cfg, FromJSON (FeatureDefaults cfg)) =>
ParseFeatureDefaults (RequiredField cfg)
where
parseFeatureDefaults obj = RequiredField <$> obj .: featureKey @cfg
newtype OptionalField cfg = OptionalField (FeatureDefaults cfg)
instance
( IsFeatureConfig cfg,
Default (FeatureDefaults cfg),
FromJSON (FeatureDefaults cfg)
) =>
ParseFeatureDefaults (OptionalField cfg)
where
parseFeatureDefaults obj = OptionalField <$> obj .:? featureKey @cfg .!= def
type FeatureFlags = AllFeatures FeatureDefaults
class (Default (FeatureDefaults cfg)) => DefaultFeatureDefaults cfg
instance (Default (FeatureDefaults cfg)) => DefaultFeatureDefaults cfg
instance Default FeatureFlags where
def = hcpure (Proxy @DefaultFeatureDefaults) def
featureDefaults ::
forall cfg.
( GetFeatureDefaults (FeatureDefaults cfg),
NpProject cfg Features
) =>
FeatureFlags ->
LockableFeature cfg
featureDefaults = featureDefaults1 . npProject
class FeatureFlagsFromObject f cfgs where
featureFlagsFromObject :: A.Object -> A.Parser (NP f cfgs)
instance FeatureFlagsFromObject f '[] where
featureFlagsFromObject _ = pure Nil
instance
( ParseFeatureDefaults (f cfg),
FeatureFlagsFromObject f cfgs
) =>
FeatureFlagsFromObject f (cfg : cfgs)
where
featureFlagsFromObject obj =
(:*)
<$> parseFeatureDefaults obj
<*> featureFlagsFromObject obj
instance
(FeatureFlagsFromObject FeatureDefaults Features) =>
FromJSON FeatureFlags
where
parseJSON = withObject "FeatureFlags" featureFlagsFromObject
class FeatureFlagsToPairs f cfgs where
featureFlagsToPairs :: NP f cfgs -> [A.Pair]
instance FeatureFlagsToPairs f '[] where
featureFlagsToPairs _ = []
instance
( ToJSON (f cfg),
IsFeatureConfig cfg,
FeatureFlagsToPairs f cfgs
) =>
FeatureFlagsToPairs f (cfg : cfgs)
where
featureFlagsToPairs (x :* xs) = (featureKey @cfg, toJSON x) : featureFlagsToPairs xs
instance ToJSON FeatureFlags where
toJSON = A.object . featureFlagsToPairs
newtype Defaults a = Defaults {_unDefaults :: a}
instance (FromJSON a) => FromJSON (Defaults a) where
parseJSON = withObject "default object" $ \ob ->
Defaults <$> (ob .: "defaults")
instance (ToJSON a) => ToJSON (Defaults a) where
toJSON (Defaults x) = A.object [("defaults", toJSON x)]
notTeamMember :: [UserId] -> [TeamMember] -> [UserId]
notTeamMember uids tmms =
Set.toList $
Set.fromList uids `Set.difference` Set.fromList (map (view userId) tmms)
isTeamMember :: (Foldable m) => UserId -> m TeamMember -> Bool
isTeamMember u = isJust . findTeamMember u
findTeamMember :: (Foldable m) => UserId -> m TeamMember -> Maybe TeamMember
findTeamMember u = find ((u ==) . view userId)
isTeamOwner :: TeamMemberOptPerms -> Bool
isTeamOwner tm = optionalPermissions tm == Just fullPermissions
canSeePermsOf :: TeamMember -> TeamMember -> Bool
canSeePermsOf seeer seeee =
seeer `hasPermission` GetMemberPermissions || seeer == seeee