diff --git a/cassandra-schema.cql b/cassandra-schema.cql index ccb834c1c8e..f34be3f2041 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -112,25 +112,6 @@ CREATE TABLE brig_test.rich_info ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; -CREATE TABLE brig_test.user_keys_hash ( - key blob PRIMARY KEY, - key_type int, - user uuid -) WITH bloom_filter_fp_chance = 0.1 - AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} - AND comment = '' - AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} - AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} - AND crc_check_chance = 1.0 - AND dclocal_read_repair_chance = 0.1 - AND default_time_to_live = 0 - AND gc_grace_seconds = 864000 - AND max_index_interval = 2048 - AND memtable_flush_period_in_ms = 0 - AND min_index_interval = 128 - AND read_repair_chance = 0.0 - AND speculative_retry = '99PERCENTILE'; - CREATE TABLE brig_test.service_tag ( bucket int, tag bigint, diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index a0fe93d2993..14861a26f04 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -592,13 +592,6 @@ legalholdUserStatus tid ownerid user = do req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidS, "legalhold", uid]) submit "GET" req --- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings -enableLegalHold :: (HasCallStack, MakesValue tid, MakesValue ownerid) => tid -> ownerid -> App Response -enableLegalHold tid ownerid = do - tidStr <- asString tid - req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) - submit "PUT" (addJSONObject ["status" .= "enabled", "ttl" .= "unlimited"] req) - -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/delete_teams__tid__legalhold__uid_ disableLegalHold :: (HasCallStack, MakesValue tid, MakesValue ownerid, MakesValue uid) => diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index f426336b6c7..af7d18900e2 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -84,21 +84,6 @@ shouldMatchWithMsg msg a b = do else pure "" assertFailure $ (maybe "" (<> "\n") msg) <> "Actual:\n" <> pa <> "\nExpected:\n" <> pb <> diff --- | apply some canonicalization transformations that *usually* do not change semantics before --- comparing. -shouldMatchLeniently :: (MakesValue a, MakesValue b, HasCallStack) => a -> b -> App () -shouldMatchLeniently = shouldMatchWithRules [EmptyArrayIsNull, RemoveNullFieldsFromObjects] (const $ pure Nothing) - --- | apply *all* canonicalization transformations before comparing. some of these may not be --- valid on your input, see 'LenientMatchRule' for details. -shouldMatchSloppily :: (MakesValue a, MakesValue b, HasCallStack) => a -> b -> App () -shouldMatchSloppily = shouldMatchWithRules [minBound ..] (const $ pure Nothing) - --- | apply *all* canonicalization transformations before comparing. some of these may not be --- valid on your input, see 'LenientMatchRule' for details. -shouldMatchALittle :: (MakesValue a, MakesValue b, HasCallStack) => (Aeson.Value -> App (Maybe Aeson.Value)) -> a -> b -> App () -shouldMatchALittle = shouldMatchWithRules [minBound ..] - data LenientMatchRule = EmptyArrayIsNull | ArraysAreSets diff --git a/libs/extended/src/Data/Time/Clock/DiffTime.hs b/libs/extended/src/Data/Time/Clock/DiffTime.hs index b84c9f9a95e..2480cf4e59d 100644 --- a/libs/extended/src/Data/Time/Clock/DiffTime.hs +++ b/libs/extended/src/Data/Time/Clock/DiffTime.hs @@ -11,7 +11,7 @@ where import Data.Time import Imports --- we really should be doing all this with https://hackage.haskell.org/package/units... +-- FUTUREWORK: we really should be doing all this with https://hackage.haskell.org/package/units... millisecondsToDiffTime :: Integer -> DiffTime millisecondsToDiffTime = picosecondsToDiffTime . (e9 *) diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 75d70c0fb14..6dbba074972 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -245,7 +245,6 @@ findTeamMember u = find ((u ==) . view userId) isTeamOwner :: TeamMemberOptPerms -> Bool isTeamOwner tm = optionalPermissions tm == Just fullPermissions --- | Use this to construct the condition expected by 'teamMemberJson', 'teamMemberListJson' canSeePermsOf :: TeamMember -> TeamMember -> Bool canSeePermsOf seeer seeee = seeer `hasPermission` GetMemberPermissions || seeer == seeee diff --git a/libs/hscim/src/Web/Scim/Client.hs b/libs/hscim/src/Web/Scim/Client.hs index c80070fb038..e736534e56e 100644 --- a/libs/hscim/src/Web/Scim/Client.hs +++ b/libs/hscim/src/Web/Scim/Client.hs @@ -31,7 +31,6 @@ module Web.Scim.Client getUsers, getUser, postUser, - putUser, patchUser, deleteUser, @@ -134,15 +133,6 @@ postUser :: IO (StoredUser tag) postUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> r)) :<|> (_ :<|> (_ :<|> _))) -> r -putUser :: - (HasScimClient tag) => - ClientEnv -> - Maybe (AuthData tag) -> - UserId tag -> - User tag -> - IO (StoredUser tag) -putUser env tok = case users (scimClients env) tok of ((_ :<|> (_ :<|> _)) :<|> (r :<|> (_ :<|> _))) -> r - patchUser :: (HasScimClient tag) => ClientEnv -> diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index ef162e09846..94ad9d1dc11 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -60,19 +60,13 @@ module Imports module UnliftIO.Directory, -- ** Prelude - putChar, putStr, putStrLn, print, - getChar, getLine, - getContents, - interact, readFile, writeFile, appendFile, - readIO, - readLn, -- ** Environment getArgs, @@ -241,9 +235,6 @@ type LByteString = Data.ByteString.Lazy.ByteString ---------------------------------------------------------------------------- -- Lifted functions from Prelude -putChar :: (MonadIO m) => Char -> m () -putChar = liftIO . P.putChar - putStr :: (MonadIO m) => String -> m () putStr = liftIO . P.putStr @@ -253,18 +244,9 @@ putStrLn = liftIO . P.putStrLn print :: (Show a, MonadIO m) => a -> m () print = liftIO . P.print -getChar :: (MonadIO m) => m Char -getChar = liftIO P.getChar - getLine :: (MonadIO m) => m String getLine = liftIO P.getLine -getContents :: (MonadIO m) => m String -getContents = liftIO P.getContents - -interact :: (MonadIO m) => (String -> String) -> m () -interact = liftIO . P.interact - readFile :: (MonadIO m) => FilePath -> m String readFile = liftIO . P.readFile @@ -274,12 +256,6 @@ writeFile = fmap liftIO . P.writeFile appendFile :: (MonadIO m) => FilePath -> String -> m () appendFile = fmap liftIO . P.appendFile -readIO :: (Read a, MonadIO m) => String -> m a -readIO = liftIO . P.readIO - -readLn :: (Read a, MonadIO m) => m a -readLn = liftIO P.readLn - ---------------------------------------------------------------------- -- Functor diff --git a/libs/wire-api/src/Wire/API/Team/Conversation.hs b/libs/wire-api/src/Wire/API/Team/Conversation.hs index 877ca425df3..d3b240d9f54 100644 --- a/libs/wire-api/src/Wire/API/Team/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Team/Conversation.hs @@ -77,9 +77,7 @@ newTeamConversation = TeamConversation -------------------------------------------------------------------------------- -- TeamConversationList -newtype TeamConversationList = TeamConversationList - { _teamConversations :: [TeamConversation] - } +newtype TeamConversationList = TeamConversationList {teamConversations :: [TeamConversation]} deriving (Generic) deriving stock (Eq, Show) deriving newtype (Arbitrary) @@ -91,10 +89,9 @@ instance ToSchema TeamConversationList where "TeamConversationList" (description ?~ "Team conversation list") $ TeamConversationList - <$> _teamConversations .= field "conversations" (array schema) + <$> teamConversations .= field "conversations" (array schema) newTeamConversationList :: [TeamConversation] -> TeamConversationList newTeamConversationList = TeamConversationList makeLenses ''TeamConversation -makeLenses ''TeamConversationList diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f2fec9ce3d6..c9f24b7b158 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -39,7 +39,6 @@ module Wire.API.Team.Feature setTTL, setWsTTL, WithStatusPatch, - wsPatch, wspStatus, wspLockStatus, wspConfig, @@ -53,7 +52,6 @@ module Wire.API.Team.Feature FeatureTTL' (..), FeatureTTLUnit (..), convertFeatureTTLDaysToSeconds, - convertFeatureTTLSecondsToDays, EnforceAppLock (..), defFeatureStatusNoLock, computeFeatureConfigForTeamUser, @@ -319,9 +317,6 @@ deriving via (Schema (WithStatusPatch cfg)) instance (ToSchema (WithStatusPatch deriving via (Schema (WithStatusPatch cfg)) instance (ToSchema (WithStatusPatch cfg), Typeable cfg) => S.ToSchema (WithStatusPatch cfg) -wsPatch :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> WithStatusPatch cfg -wsPatch = WithStatusBase - wspStatus :: WithStatusPatch cfg -> Maybe FeatureStatus wspStatus = wsbStatus @@ -421,10 +416,6 @@ convertFeatureTTLDaysToSeconds :: FeatureTTLDays -> FeatureTTL convertFeatureTTLDaysToSeconds FeatureTTLUnlimited = FeatureTTLUnlimited convertFeatureTTLDaysToSeconds (FeatureTTLSeconds d) = FeatureTTLSeconds (d * (60 * 60 * 24)) -convertFeatureTTLSecondsToDays :: FeatureTTL -> FeatureTTLDays -convertFeatureTTLSecondsToDays FeatureTTLUnlimited = FeatureTTLUnlimited -convertFeatureTTLSecondsToDays (FeatureTTLSeconds d) = FeatureTTLSeconds (d `div` (60 * 60 * 24)) - instance Arbitrary FeatureTTL where arbitrary = (nonZero <$> arbitrary) diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 812c63c000d..d94cbfecc32 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -28,7 +28,6 @@ module Wire.API.Team.Member invitation, legalHoldStatus, ntmNewTeamMember, - teamMemberJson, setOptionalPerms, setOptionalPermsMany, teamMemberObjectSchema, @@ -426,9 +425,6 @@ permissions = newTeamMember . nPermissions invitation :: Lens' TeamMember (Maybe (UserId, UTCTimeMillis)) invitation = newTeamMember . nInvitation -teamMemberJson :: (TeamMember -> Bool) -> TeamMember -> Value -teamMemberJson withPerms = toJSON . setOptionalPerms withPerms - setOptionalPerms :: (TeamMember -> Bool) -> TeamMember -> TeamMember' 'Optional setOptionalPerms withPerms m = m & permissions %~ setPerm (withPerms m) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 9477ace1dc0..d3692bb5900 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -62,7 +62,6 @@ module Wire.API.User urefToExternalIdUnsafe, urefToEmail, ExpiresIn, - newUserInvitationCode, newUserTeam, newUserEmail, newUserSSOId, @@ -1169,11 +1168,6 @@ instance Arbitrary NewUser where genUserExpiresIn newUserIdentity = if isJust newUserIdentity then pure Nothing else arbitrary -newUserInvitationCode :: NewUser -> Maybe InvitationCode -newUserInvitationCode nu = case newUserOrigin nu of - Just (NewUserOriginInvitationCode ic) -> Just ic - _ -> Nothing - newUserTeam :: NewUser -> Maybe NewTeamUser newUserTeam nu = case newUserOrigin nu of Just (NewUserOriginTeamUser tu) -> Just tu diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index eef98189def..806f9745c14 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -21,7 +21,6 @@ module Wire.API.User.Auth ( -- * Login Login (..), - loginLabel, LoginCode (..), LoginId (..), PendingLoginCode (..), @@ -347,9 +346,6 @@ instance ToSchema Login where <*> lLabel .= optField "label" (maybeWithDefault A.Null schema) <*> lCode .= optField "verification_code" (maybeWithDefault A.Null schema) -loginLabel :: Login -> Maybe CookieLabel -loginLabel = lLabel - -------------------------------------------------------------------------------- -- RemoveCookies diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 35bbde4892d..fc80e19c4e7 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -36,7 +36,6 @@ module Wire.API.User.Client mkQualifiedUserClientPrekeyMap, qualifiedUserClientPrekeyMapFromList, UserClientsFull (..), - userClientsFullToUserClients, UserClients (..), mkUserClients, QualifiedUserClients (..), @@ -394,9 +393,6 @@ instance FromJSON UserClientsFull where instance Arbitrary UserClientsFull where arbitrary = UserClientsFull <$> mapOf' arbitrary (setOf' arbitrary) -userClientsFullToUserClients :: UserClientsFull -> UserClients -userClientsFullToUserClients (UserClientsFull mp) = UserClients $ Set.map clientId <$> mp - newtype UserClients = UserClients { userClients :: Map UserId (Set ClientId) } diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index b96ad4135fa..a06c5beb64b 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -44,7 +44,6 @@ module Wire.API.User.Identity -- * UserSSOId UserSSOId (..), emailFromSAML, - emailToSAML, emailToSAMLNameID, emailFromSAMLNameID, mkSampleUref, @@ -421,9 +420,6 @@ lenientlyParseSAMLNameID (Just txt) = do emailFromSAML :: (HasCallStack) => SAMLEmail.Email -> Email emailFromSAML = fromJust . parseEmail . SAMLEmail.render -emailToSAML :: (HasCallStack) => Email -> SAMLEmail.Email -emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString - -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this -- function total without all that praying and hoping. emailToSAMLNameID :: (HasCallStack) => Email -> SAML.NameID diff --git a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs index 9100be731e2..7283333f7a2 100644 --- a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs +++ b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs @@ -132,13 +132,9 @@ instance Cql.Cql WireIdPAPIVersion where -- | A list of 'IdP's, returned by some endpoints. Wrapped into an object to -- allow extensibility later on. -data IdPList = IdPList - { _providers :: [IdP] - } +newtype IdPList = IdPList {providers :: [IdP]} deriving (Eq, Show, Generic) -makeLenses ''IdPList - -- Same as WireIdP, we want the lenses, so we have to drop a prefix deriveJSON (defaultOptsDropChar '_') ''IdPList diff --git a/libs/wire-api/src/Wire/API/User/Saml.hs b/libs/wire-api/src/Wire/API/User/Saml.hs index fa97f24fb07..4bebb7bf6d0 100644 --- a/libs/wire-api/src/Wire/API/User/Saml.hs +++ b/libs/wire-api/src/Wire/API/User/Saml.hs @@ -24,7 +24,6 @@ -- for them. module Wire.API.User.Saml where -import Control.Lens (makeLenses) import Control.Monad.Except import Data.Aeson hiding (fieldLabelModifier) import Data.Aeson.TH hiding (fieldLabelModifier) @@ -62,8 +61,6 @@ data VerdictFormat | VerdictFormatMobile {_formatGrantedURI :: URI, _formatDeniedURI :: URI} deriving (Eq, Show, Generic) -makeLenses ''VerdictFormat - deriveJSON deriveJSONOptions ''VerdictFormat mkVerdictGrantedFormatMobile :: (MonadError String m) => URI -> SetCookie -> UserId -> m URI diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index e27bfcb26d2..23360888ad5 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -382,13 +382,6 @@ veidUref = prism' UrefOnly $ UrefOnly uref -> Just uref EmailOnly _ -> Nothing -veidEmail :: Prism' ValidExternalId Email -veidEmail = prism' EmailOnly $ - \case - EmailAndUref em _ -> Just em - UrefOnly _ -> Nothing - EmailOnly em -> Just em - makeLenses ''ValidScimUser makeLenses ''ValidExternalId diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index dfeb601c4e0..455c0c0d2a4 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. -- @@ -35,7 +34,7 @@ where import Cassandra qualified as C import Control.Error -import Control.Lens (makePrisms, (?~)) +import Control.Lens ((?~)) import Data.Aeson hiding (object, (.=)) import Data.Aeson qualified as Aeson import Data.Attoparsec.ByteString (sepBy) @@ -329,5 +328,3 @@ instance C.Cql FederatedUserSearchPolicy where fromCql (C.CqlInt 1) = pure ExactHandleSearch fromCql (C.CqlInt 2) = pure FullSearch fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n - -makePrisms ''FederatedUserSearchPolicy diff --git a/libs/wire-api/src/Wire/API/UserEvent.hs b/libs/wire-api/src/Wire/API/UserEvent.hs index 5f54e7ea54d..acc39c3ebc2 100644 --- a/libs/wire-api/src/Wire/API/UserEvent.hs +++ b/libs/wire-api/src/Wire/API/UserEvent.hs @@ -200,36 +200,6 @@ phoneUpdated :: UserId -> Phone -> UserEvent phoneUpdated u p = UserIdentityUpdated $ UserIdentityUpdatedData u Nothing (Just p) -handleUpdated :: UserId -> Handle -> UserEvent -handleUpdated u h = - UserUpdated $ (emptyUserUpdatedData u) {eupHandle = Just h} - -localeUpdate :: UserId -> Locale -> UserEvent -localeUpdate u loc = - UserUpdated $ (emptyUserUpdatedData u) {eupLocale = Just loc} - -managedByUpdate :: UserId -> ManagedBy -> UserEvent -managedByUpdate u mb = - UserUpdated $ (emptyUserUpdatedData u) {eupManagedBy = Just mb} - -supportedProtocolUpdate :: UserId -> Set BaseProtocolTag -> UserEvent -supportedProtocolUpdate u prots = - UserUpdated $ (emptyUserUpdatedData u) {eupSupportedProtocols = Just prots} - -profileUpdated :: UserId -> UserUpdate -> UserEvent -profileUpdated u UserUpdate {..} = - UserUpdated $ - (emptyUserUpdatedData u) - { eupName = uupName, - eupTextStatus = uupTextStatus, - eupPict = uupPict, - eupAccentId = uupAccentId, - eupAssets = uupAssets - } - -emptyUpdate :: UserId -> UserEvent -emptyUpdate = UserUpdated . emptyUserUpdatedData - emptyUserUpdatedData :: UserId -> UserUpdatedData emptyUserUpdatedData u = UserUpdatedData diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index d2c152497d3..fe01eb3ec34 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -86,6 +86,7 @@ import Test.Wire.API.Golden.Generated.Event_conversation qualified import Test.Wire.API.Golden.Generated.Event_featureConfig qualified import Test.Wire.API.Golden.Generated.Event_team qualified import Test.Wire.API.Golden.Generated.Event_user qualified +import Test.Wire.API.Golden.Generated.FeatureStatus_team qualified import Test.Wire.API.Golden.Generated.HandleUpdate_user qualified import Test.Wire.API.Golden.Generated.InvitationCode_user qualified import Test.Wire.API.Golden.Generated.InvitationList_team qualified @@ -1428,6 +1429,30 @@ tests = (Test.Wire.API.Golden.Generated.Event_featureConfig.testObject_Event_featureConfig_9, "testObject_Event_featureConfig_9.json"), (Test.Wire.API.Golden.Generated.Event_featureConfig.testObject_Event_featureConfig_10, "testObject_Event_featureConfig_10.json") ], + testGroup + "Golden: FeatureStatus_team" + $ testObjects + [ (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_1, "testObject_FeatureStatus_team_1.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_2, "testObject_FeatureStatus_team_2.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_3, "testObject_FeatureStatus_team_3.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_4, "testObject_FeatureStatus_team_4.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_5, "testObject_FeatureStatus_team_5.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_6, "testObject_FeatureStatus_team_6.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_7, "testObject_FeatureStatus_team_7.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_8, "testObject_FeatureStatus_team_8.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_9, "testObject_FeatureStatus_team_9.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_10, "testObject_FeatureStatus_team_10.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_11, "testObject_FeatureStatus_team_11.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_12, "testObject_FeatureStatus_team_12.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_13, "testObject_FeatureStatus_team_13.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_14, "testObject_FeatureStatus_team_14.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_15, "testObject_FeatureStatus_team_15.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_16, "testObject_FeatureStatus_team_16.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_17, "testObject_FeatureStatus_team_17.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_18, "testObject_FeatureStatus_team_18.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_19, "testObject_FeatureStatus_team_19.json"), + (Test.Wire.API.Golden.Generated.FeatureStatus_team.testObject_FeatureStatus_team_20, "testObject_FeatureStatus_team_20.json") + ], testGroup "Golden: Event_Conversation" $ testObjects diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_1.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_1.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_1.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_10.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_10.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_10.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_11.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_11.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_11.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_12.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_12.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_12.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_13.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_13.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_13.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_14.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_14.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_14.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_15.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_15.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_15.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_16.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_16.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_16.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_17.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_17.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_17.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_18.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_18.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_18.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_19.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_19.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_19.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_2.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_2.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_2.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_20.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_20.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_20.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_3.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_3.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_3.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_4.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_4.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_4.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_5.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_5.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_5.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_6.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_6.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_6.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_7.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_7.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_7.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_8.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_8.json new file mode 100644 index 00000000000..78bf971c5a4 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_8.json @@ -0,0 +1 @@ +"enabled" diff --git a/libs/wire-api/test/golden/testObject_FeatureStatus_team_9.json b/libs/wire-api/test/golden/testObject_FeatureStatus_team_9.json new file mode 100644 index 00000000000..a0760977f71 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_FeatureStatus_team_9.json @@ -0,0 +1 @@ +"disabled" diff --git a/libs/wire-api/test/unit/Test/Wire/API/Password.hs b/libs/wire-api/test/unit/Test/Wire/API/Password.hs index e55bf2ff6cf..8850a377c79 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Password.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Password.hs @@ -32,6 +32,8 @@ tests = testCase "verify old scrypt password still works" testHashingOldScrypt ] +-- TODO: Address password hashing being wrong +-- https://wearezeta.atlassian.net/browse/WPB-9746 testHashPasswordScrypt :: IO () testHashPasswordScrypt = do pwd <- genPassword diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 499b1eb12e4..96d9d4c221b 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -13,14 +13,12 @@ import Polysemy import Wire.Arbitrary data Recipient = Recipient - { _recipientUserId :: UserId, - _recipientClients :: RecipientClients + { recipientUserId :: UserId, + recipientClients :: RecipientClients } deriving stock (Show, Ord, Eq, Generic) deriving (Arbitrary) via GenericUniform Recipient -makeLenses ''Recipient - data Push = Push { _pushConn :: Maybe ConnId, _pushTransient :: Bool, diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index f59c79d0c2d..7f14c802389 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -128,8 +128,8 @@ toV2Push p = recipients = map toRecipient $ toList p._pushRecipients toRecipient :: Recipient -> V2.Recipient toRecipient r = - (recipient r._recipientUserId p._pushRoute) - { V2._recipientClients = r._recipientClients + (recipient r.recipientUserId p._pushRoute) + { V2._recipientClients = r.recipientClients } {-# INLINE [1] chunkPushes #-} diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 0838da2bb18..398bb85145c 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -96,6 +96,3 @@ getUserProfile luid targetUser = getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) - -updateSupportedProtocols :: (Member UserSubsystem r) => Local UserId -> UpdateOriginType -> Set BaseProtocolTag -> Sem r () -updateSupportedProtocols uid mb prots = updateUserProfile uid Nothing mb (def {supportedProtocols = Just prots}) diff --git a/libs/zauth/src/Data/ZAuth/Creation.hs b/libs/zauth/src/Data/ZAuth/Creation.hs index f7dfda93d17..54fec4f357d 100644 --- a/libs/zauth/src/Data/ZAuth/Creation.hs +++ b/libs/zauth/src/Data/ZAuth/Creation.hs @@ -39,13 +39,12 @@ module Data.ZAuth.Creation legalHoldUserToken, -- * Generic - withIndex, newToken, renewToken, ) where -import Control.Lens hiding (withIndex) +import Control.Lens import Control.Monad.Catch (MonadCatch, MonadThrow) import Data.ByteString qualified as Strict import Data.ByteString.Builder (toLazyByteString) @@ -90,13 +89,6 @@ runCreate z k m = do error "runCreate: Key index out of range." runReaderT (zauth m) (z {keyIdx = k}) -withIndex :: Int -> Create a -> Create a -withIndex k m = Create $ do - e <- ask - when (k < 1 || k > Vec.length (zSign e)) $ - error "withIndex: Key index out of range." - local (const (e {keyIdx = k})) (zauth m) - userToken :: Integer -> UUID -> Maybe Text -> Word32 -> Create (Token User) userToken dur usr cli rnd = do d <- expiry dur diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 7c6fbf48aab..57ccf6bf0e1 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -9,7 +9,6 @@ import Util.Options (Endpoint (..)) import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options -import Wire.BackgroundWorker.Util testEnv :: IO Env testEnv = do @@ -34,18 +33,3 @@ runTestAppTWithEnv :: Env -> AppT IO a -> Int -> IO a runTestAppTWithEnv Env {..} app port = do let env = Env {federatorInternal = Endpoint "localhost" (fromIntegral port), ..} runAppT env app - -data FakeEnvelope = FakeEnvelope - { rejections :: IORef [Bool], - acks :: IORef Int - } - -newFakeEnvelope :: IO FakeEnvelope -newFakeEnvelope = - FakeEnvelope - <$> newIORef [] - <*> newIORef 0 - -instance RabbitMQEnvelope FakeEnvelope where - ack e = atomicModifyIORef' e.acks $ \a -> (a + 1, ()) - reject e requeueFlag = atomicModifyIORef' e.rejections $ \r -> (r <> [requeueFlag], ()) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 91dd6a130ac..377b7cdcf86 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -107,7 +107,6 @@ library Brig.Data.Activation Brig.Data.Client Brig.Data.Connection - Brig.Data.LoginCode Brig.Data.MLS.KeyPackage Brig.Data.Nonce Brig.Data.Types @@ -187,7 +186,7 @@ library Brig.Schema.V82_DropPhoneColumn Brig.Schema.V83_AddTextStatus Brig.Schema.V84_DropTeamInvitationPhone - Brig.Schema.V_FUTUREWORK + Brig.Schema.V85_DropUserKeysHashed Brig.Team.API Brig.Team.DB Brig.Team.Email diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index dad9ecdefe6..2d865be62c6 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -34,7 +34,6 @@ module Brig.API.User Data.lookupAccounts, Data.lookupAccount, lookupAccountsByIdentity, - lookupProfilesV3, getLegalHoldStatus, Data.lookupName, Data.lookupUser, @@ -126,7 +125,6 @@ import UnliftIO.Async (mapConcurrently_) import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Brig qualified as E -import Wire.API.Federation.Error import Wire.API.Password import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) @@ -1132,16 +1130,6 @@ enqueueMultiDeleteCallsCounter = Prom.metricHelp = "Number of users enqueued to be deleted" } --- | Similar to lookupProfiles except it returns all results and all errors --- allowing for partial success. -lookupProfilesV3 :: - (Member UserSubsystem r) => - Local UserId -> - -- | The users ('others') for which to obtain the profiles. - [Qualified UserId] -> - Sem r ([(Qualified UserId, FederationError)], [UserProfile]) -lookupProfilesV3 self others = getUserProfilesWithErrors self others - getLegalHoldStatus :: (Member GalleyAPIAccess r) => UserId -> diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 6a1d1d532d7..77c08763f89 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -17,54 +17,34 @@ module Brig.API.Util ( fetchUserIdentity, - lookupProfilesMaybeFilterSameTeamOnly, logInvitationCode, - validateHandle, logEmail, - traverseConcurrentlyAppT, traverseConcurrentlySem, traverseConcurrentlyWithErrors, - traverseConcurrentlyWithErrorsSem, - traverseConcurrentlyWithErrorsAppT, exceptTToMaybe, ensureLocal, ) where -import Brig.API.Error -import Brig.API.Handler import Brig.API.Types import Brig.App -import Brig.Data.User qualified as Data import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import Data.Bifunctor -import Data.Handle (Handle, parseHandle) import Data.Id import Data.Maybe import Data.Text qualified as T import Data.Text.Ascii (AsciiText (toText)) import Imports import Polysemy -import Polysemy.Error qualified as E import System.Logger (Msg) import System.Logger qualified as Log import UnliftIO.Async import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) -import Wire.API.Error -import Wire.API.Error.Brig import Wire.API.User -import Wire.Sem.Concurrency qualified as C import Wire.UserSubsystem -lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] -lookupProfilesMaybeFilterSameTeamOnly self us = do - selfTeam <- lift $ wrapClient $ Data.lookupUserTeam self - pure $ case selfTeam of - Just team -> filter (\x -> profileTeam x == Just team) us - Nothing -> us - fetchUserIdentity :: (Member UserSubsystem r) => UserId -> AppT r (Maybe UserIdentity) fetchUserIdentity uid = do luid <- qualifyLocal uid @@ -73,9 +53,6 @@ fetchUserIdentity uid = do (throwM $ UserProfileNotFound uid) (pure . userIdentity . selfUser) -validateHandle :: Text -> (Handler r) Handle -validateHandle = maybe (throwStd (errorToWai @'InvalidHandle)) pure . parseHandle - logEmail :: Email -> (Msg -> Msg) logEmail email = Log.field "email_sha256" (sha256String . T.pack . show $ email) @@ -83,21 +60,6 @@ logEmail email = logInvitationCode :: InvitationCode -> (Msg -> Msg) logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCode code) --- | Traverse concurrently and collect errors. -traverseConcurrentlyAppT :: - (Traversable t, Member (C.Concurrency 'C.Unsafe) r) => - (a -> ExceptT e (AppT r) b) -> - t a -> - AppT r [Either (a, e) b] -traverseConcurrentlyAppT f t = do - env <- temporaryGetEnv - AppT $ - lift $ - C.unsafePooledMapConcurrentlyN - 8 - (\a -> first (a,) <$> lowerAppT env (runExceptT $ f a)) - t - -- | Traverse concurrently and fail on first error. traverseConcurrentlyWithErrors :: (Traversable t, Exception e, MonadUnliftIO m) => @@ -119,35 +81,5 @@ traverseConcurrentlySem :: traverseConcurrentlySem f = pooledMapConcurrentlyN 8 $ \a -> first (a,) <$> runExceptT (f a) --- | Traverse concurrently and fail on first error. -traverseConcurrentlyWithErrorsSem :: - forall t e a r b. - (Traversable t, Member (C.Concurrency 'C.Unsafe) r) => - (a -> ExceptT e (Sem r) b) -> - t a -> - ExceptT e (Sem r) [b] -traverseConcurrentlyWithErrorsSem f = - ExceptT - . E.runError - . ( traverse (either E.throw pure) - <=< C.unsafePooledMapConcurrentlyN 8 (raise . runExceptT . f) - ) - -traverseConcurrentlyWithErrorsAppT :: - forall t e a r b. - (Traversable t, Member (C.Concurrency 'C.Unsafe) r) => - (a -> ExceptT e (AppT r) b) -> - t a -> - ExceptT e (AppT r) [b] -traverseConcurrentlyWithErrorsAppT f t = do - env <- lift temporaryGetEnv - ExceptT $ - AppT $ - lift $ - runExceptT $ - traverseConcurrentlyWithErrorsSem - (mapExceptT (lowerAppT env) . f) - t - exceptTToMaybe :: (Monad m) => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 9d475b37262..4c9e0e75b74 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -40,7 +40,6 @@ module Brig.App federator, casClient, userTemplates, - usrTemplates, providerTemplates, teamTemplates, templateBranding, @@ -181,7 +180,7 @@ data Env = Env _applog :: Logger, _internalEvents :: QueueEnv, _requestId :: RequestId, - _usrTemplates :: Localised UserTemplates, + _userTemplates :: Localised UserTemplates, _provTemplates :: Localised ProviderTemplates, _tmTemplates :: Localised TeamTemplates, _templateBranding :: TemplateBranding, @@ -277,7 +276,7 @@ newEnv o = do _applog = lgr, _internalEvents = (eventsQueue :: QueueEnv), _requestId = RequestId "N/A", - _usrTemplates = utp, + _userTemplates = utp, _provTemplates = ptp, _tmTemplates = ttp, _templateBranding = branding, @@ -437,9 +436,6 @@ initCassandra o g = (Just schemaVersion) g -userTemplates :: (MonadReader Env m) => Maybe Locale -> m (Locale, UserTemplates) -userTemplates l = forLocale l <$> view usrTemplates - providerTemplates :: (MonadReader Env m) => Maybe Locale -> m (Locale, ProviderTemplates) providerTemplates l = forLocale l <$> view provTemplates diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 62aca48a5f8..ca597c1063a 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -213,7 +213,7 @@ runBrigToIO e (AppT ma) = do . runDeleteQueue (e ^. internalEvents) . interpretPropertySubsystem propertySubsystemConfig . interpretVerificationCodeSubsystem - . emailSubsystemInterpreter (e ^. usrTemplates) (e ^. templateBranding) + . emailSubsystemInterpreter (e ^. userTemplates) (e ^. templateBranding) . runUserSubsystem userSubsystemConfig . interpretAuthenticationSubsystem ) diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index ef2909b35d9..4c0c2b3415c 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -27,7 +27,6 @@ module Brig.Data.Client addClientWithReAuthPolicy, addClient, rmClient, - hasClient, lookupClient, lookupClients, lookupPubClientsBulk, @@ -238,9 +237,6 @@ lookupPrekeyIds u c = map runIdentity <$> retry x1 (query selectPrekeyIds (params LocalQuorum (u, c))) -hasClient :: (MonadClient m) => UserId -> ClientId -> m Bool -hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) - rmClient :: ( MonadClient m, MonadReader Brig.App.Env m, @@ -416,9 +412,6 @@ selectPrekeyIds = "SELECT key FROM prekeys where user = ? and client = ?" removePrekey :: PrepQuery W (UserId, ClientId, PrekeyId) () removePrekey = "DELETE FROM prekeys where user = ? and client = ? and key = ?" -checkClient :: PrepQuery R (UserId, ClientId) (Identity ClientId) -checkClient = "SELECT client from clients where user = ? and client = ?" - selectMLSPublicKey :: PrepQuery R (UserId, ClientId, SignatureSchemeTag) (Identity Blob) selectMLSPublicKey = "SELECT key from mls_public_keys where user = ? and client = ? and sig_scheme = ?" diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index ff843f215f4..fbe8221018e 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -21,7 +21,6 @@ module Brig.Data.Connection updateConnection, updateConnectionStatus, lookupConnection, - lookupRelation, lookupLocalConnectionsPage, lookupRemoteConnectionsPage, lookupRelationWithHistory, @@ -33,17 +32,14 @@ module Brig.Data.Connection lookupLocalConnectionStatuses, lookupRemoteConnectionStatuses, lookupAllStatuses, - lookupRemoteConnectedUsersC, lookupRemoteConnectedUsersPaginated, countConnections, deleteConnections, deleteRemoteConnections, - deleteRemoteConnectionsDomain, remoteConnectionInsert, remoteConnectionSelect, remoteConnectionSelectFrom, remoteConnectionDelete, - remoteConnectionSelectFromDomain, remoteConnectionClear, -- * Re-exports @@ -56,7 +52,7 @@ import Brig.Data.Types as T import Cassandra import Control.Monad.Morph import Control.Monad.Trans.Maybe -import Data.Conduit (ConduitT, runConduit, (.|)) +import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as C import Data.Domain (Domain) import Data.Id @@ -154,12 +150,6 @@ lookupRelationWithHistory self target = do query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) -lookupRelation :: (MonadClient m) => Local UserId -> Qualified UserId -> m Relation -lookupRelation self target = - lookupRelationWithHistory self target <&> \case - Nothing -> Cancelled - Just relh -> (relationDropHistory relh) - -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. lookupLocalConnections :: (MonadClient m) => @@ -267,11 +257,6 @@ lookupAllStatuses lfroms = do map (\(d, u, r) -> toConnectionStatusV2 from d u r) <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) -lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => Local UserId -> Int32 -> ConduitT () [Remote UserConnection] m () -lookupRemoteConnectedUsersC u maxResults = - paginateC remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults) x1 - .| C.map (\xs -> map (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) xs) - lookupRemoteConnectedUsersPaginated :: (MonadClient m) => Local UserId -> Int32 -> m (Page (Remote UserConnection)) lookupRemoteConnectedUsersPaginated u maxResults = do (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) @@ -329,14 +314,6 @@ deleteRemoteConnections (tUntagged -> Qualified remoteUser remoteDomain) (fromRa pooledForConcurrentlyN_ 16 locals $ \u -> write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) -deleteRemoteConnectionsDomain :: (MonadClient m, MonadUnliftIO m) => Domain -> m () -deleteRemoteConnectionsDomain dom = do - -- Select all triples for the given domain, and then delete them - runConduit $ - paginateC remoteConnectionSelectFromDomain (paramsP LocalQuorum (pure dom) 100) x1 - .| C.mapM_ - (pooledMapConcurrentlyN_ 16 $ write remoteConnectionDelete . params LocalQuorum) - -- Queries connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () @@ -399,9 +376,6 @@ remoteConnectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDA remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" -remoteConnectionSelectFromDomain :: PrepQuery R (Identity Domain) (UserId, Domain, UserId) -remoteConnectionSelectFromDomain = "SELECT left, right_domain, right_user FROM connection_remote where right_domain = ?" - remoteConnectionClear :: PrepQuery W (Identity UserId) () remoteConnectionClear = "DELETE FROM connection_remote where left = ?" diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs deleted file mode 100644 index 3103e939747..00000000000 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ /dev/null @@ -1,93 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - --- | Persistent storage for login codes. --- TODO: Use Brig.Data.Codes --- TODO: Move to Brig.User.Auth.DB.LoginCode -module Brig.Data.LoginCode - ( LoginCode, - createLoginCode, - verifyLoginCode, - lookupLoginCode, - ) -where - -import Brig.App (Env, currentTime) -import Cassandra -import Control.Lens (view) -import Data.Code -import Data.Id -import Data.Text qualified as T -import Data.Time.Clock -import Imports -import OpenSSL.BN (randIntegerZeroToNMinusOne) -import Text.Printf (printf) -import Wire.API.User.Auth - --- | Max. number of verification attempts per code. -maxAttempts :: Int32 -maxAttempts = 3 - --- | Timeout of individual codes. -ttl :: NominalDiffTime -ttl = 600 - -createLoginCode :: (MonadClient m, MonadReader Env m) => UserId -> m PendingLoginCode -createLoginCode u = do - now <- liftIO =<< view currentTime - code <- liftIO genCode - insertLoginCode u code maxAttempts (ttl `addUTCTime` now) - pure $! PendingLoginCode code (Timeout ttl) - where - genCode = LoginCode . T.pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 - -verifyLoginCode :: (MonadClient m, MonadReader Env m) => UserId -> LoginCode -> m Bool -verifyLoginCode u c = do - code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) - now <- liftIO =<< view currentTime - case code of - Just (c', _, t) | c == c' && t >= now -> deleteLoginCode u >> pure True - Just (c', n, t) | n > 1 && t > now -> insertLoginCode u c' (n - 1) t >> pure False - Just (_, _, _) -> deleteLoginCode u >> pure False - Nothing -> pure False - -lookupLoginCode :: (MonadReader Env m, MonadClient m) => UserId -> m (Maybe PendingLoginCode) -lookupLoginCode u = do - now <- liftIO =<< view currentTime - validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) - where - validate now (Just (c, _, t)) | now < t = pure (Just (pending c now t)) - validate _ _ = pure Nothing - pending c now t = PendingLoginCode c (timeout now t) - timeout now t = Timeout (t `diffUTCTime` now) - -deleteLoginCode :: (MonadClient m) => UserId -> m () -deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) - -insertLoginCode :: (MonadClient m) => UserId -> LoginCode -> Int32 -> UTCTime -> m () -insertLoginCode u c n t = retry x5 . write codeInsert $ params LocalQuorum (u, c, n, t, round ttl) - --- Queries - -codeInsert :: PrepQuery W (UserId, LoginCode, Int32, UTCTime, Int32) () -codeInsert = "INSERT INTO login_codes (user, code, retries, timeout) VALUES (?, ?, ?, ?) USING TTL ?" - -codeSelect :: PrepQuery R (Identity UserId) (LoginCode, Int32, UTCTime) -codeSelect = "SELECT code, retries, timeout FROM login_codes WHERE user = ?" - -codeDelete :: PrepQuery W (Identity UserId) () -codeDelete = "DELETE FROM login_codes WHERE user = ?" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 66e4ea9d69e..96a1c81341b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -743,9 +743,6 @@ instance ToJSON AccountFeatureConfigs where getAfcConferenceCallingDefNewMaybe :: Lens.Getter Settings (Maybe (Public.WithStatus Public.ConferenceCallingConfig)) getAfcConferenceCallingDefNewMaybe = Lens.to (Lens.^? (Lens.to setFeatureFlags . Lens._Just . Lens.to afcConferenceCallingDefNew . unImplicitLockStatus)) -getAfcConferenceCallingDefNullMaybe :: Lens.Getter Settings (Maybe (Public.WithStatus Public.ConferenceCallingConfig)) -getAfcConferenceCallingDefNullMaybe = Lens.to (Lens.^? (Lens.to setFeatureFlags . Lens._Just . Lens.to afcConferenceCallingDefNull . unImplicitLockStatus)) - getAfcConferenceCallingDefNew :: Lens.Getter Settings (Public.WithStatus Public.ConferenceCallingConfig) getAfcConferenceCallingDefNew = Lens.to (Public._unImplicitLockStatus . afcConferenceCallingDefNew . fromMaybe defAccountFeatureConfigs . setFeatureFlags) @@ -944,6 +941,4 @@ Lens.makeLensesFor ] ''ElasticSearchOpts -Lens.makeLensesFor [("sftBaseDomain", "sftBaseDomainL")] ''SFTOptions - Lens.makeLensesFor [("serversSource", "serversSourceL")] ''TurnOpts diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index 1b8f329c240..2e95cbb0ded 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -19,7 +19,6 @@ module Brig.Provider.Email ( sendActivationMail, - sendApprovalRequestMail, sendApprovalConfirmMail, sendPasswordResetMail, ) @@ -28,17 +27,14 @@ where import Brig.App import Brig.Provider.Template import Control.Lens (view) -import Data.ByteString.Conversion import Data.Code qualified as Code import Data.Range import Data.Text (pack) import Data.Text.Ascii qualified as Ascii -import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as LT import Imports import Network.Mail.Mime import Polysemy -import Wire.API.Provider import Wire.API.User import Wire.EmailSending import Wire.EmailSubsystem.Interpreter (mkMimeAddress) @@ -96,57 +92,6 @@ renderActivationUrl t (Code.Key k) (Code.Value v) branding = replace "code" = Ascii.toText (fromRange v) replace x = x --------------------------------------------------------------------------------- --- Approval Request Email - -sendApprovalRequestMail :: (Member EmailSending r) => Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppT r) () -sendApprovalRequestMail name email url descr key val = do - tpl <- approvalRequestEmail . snd <$> providerTemplates Nothing - branding <- view templateBranding - let mail = ApprovalRequestEmail email name url descr key val - liftSem $ sendMail $ renderApprovalRequestMail mail tpl branding - -data ApprovalRequestEmail = ApprovalRequestEmail - { aprTo :: !Email, - aprName :: !Name, - aprUrl :: !HttpsUrl, - aprDescr :: !Text, - aprKey :: !Code.Key, - aprCode :: !Code.Value - } - -renderApprovalRequestMail :: ApprovalRequestEmail -> ApprovalRequestEmailTemplate -> TemplateBranding -> Mail -renderApprovalRequestMail ApprovalRequestEmail {..} ApprovalRequestEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", LT.toStrict subj), - ("X-Zeta-Purpose", "ProviderApprovalRequest") - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just approvalRequestEmailSenderName) (fromEmail approvalRequestEmailSender) - to = Address (Just "Provider Approval Staff") (fromEmail approvalRequestEmailTo) - txt = renderTextWithBranding approvalRequestEmailBodyText replace branding - html = renderHtmlWithBranding approvalRequestEmailBodyHtml replace branding - subj = renderTextWithBranding approvalRequestEmailSubject replace branding - replace "email" = fromEmail aprTo - replace "name" = fromName aprName - replace "url" = Text.decodeUtf8 (toByteString' aprUrl) - replace "description" = aprDescr - replace "approvalUrl" = renderApprovalUrl approvalRequestEmailUrl aprKey aprCode branding - replace x = x - --- TODO: Unify with renderActivationUrl -renderApprovalUrl :: Template -> Code.Key -> Code.Value -> TemplateBranding -> Text -renderApprovalUrl t (Code.Key k) (Code.Value v) branding = - LT.toStrict $ renderTextWithBranding t replace branding - where - replace "key" = Ascii.toText (fromRange k) - replace "code" = Ascii.toText (fromRange v) - replace x = x - -------------------------------------------------------------------------------- -- Approval Confirmation Email diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index a5e7d4d275b..3772b57fc08 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -18,68 +18,19 @@ -- | Working with remote queues (like Amazon SQS). module Brig.Queue ( module Brig.Queue.Types, - enqueue, listen, ) where -import Amazonka.SQS.Lens (sendMessageResponse_mD5OfMessageBody) import Brig.AWS qualified as AWS -import Brig.App import Brig.DeleteQueue.Interpreter (QueueEnv (..)) import Brig.Queue.Stomp qualified as Stomp import Brig.Queue.Types -import Control.Exception (ErrorCall (..)) -import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.Aeson -import Data.ByteString.Base16 qualified as B16 -import Data.ByteString.Lazy qualified as BL -import Data.Text.Encoding qualified as T import Imports -import OpenSSL.EVP.Digest (Digest, digestLBS) import System.Logger.Class as Log hiding (settings) --- Note [queue refactoring] --- ~~~~~~~~~~~~~~~~ --- --- The way we deal with queues is not the best. There is at least one piece of --- technical debt here: --- --- 1. 'Queue' is currently used only for the internal events queue, even --- though we have queues in other places (and not only in Brig). We --- should move 'Brig.Queue' out of Brig and use it elsewhere too. - --- | Enqueue a message. --- --- Throws an error in case of failure. -enqueue :: - ( MonadReader Env m, - ToJSON a, - MonadIO m, - MonadLogger m, - MonadThrow m - ) => - QueueEnv -> - a -> - m () -enqueue (StompQueueEnv env queue) message = - Stomp.enqueue env queue message -enqueue (SqsQueueEnv env _ queue) message = do - let body = encode message - bodyMD5 <- digest <$> view digestMD5 <*> pure body - resp <- AWS.execute env (AWS.enqueueStandard queue body) - unless (resp ^. sendMessageResponse_mD5OfMessageBody == Just bodyMD5) $ do - Log.err $ - msg (val "Returned hash (MD5) doesn't match message hash") - . field "SqsQueue" (show queue) - . field "returned_hash" (show (resp ^. sendMessageResponse_mD5OfMessageBody)) - . field "message_hash" (show (Just bodyMD5)) - throwM (ErrorCall "The server couldn't access a queue") - where - digest :: Digest -> BL.ByteString -> Text - digest d = T.decodeLatin1 . B16.encode . digestLBS d - -- | Forever listen to messages coming from a queue and execute a callback -- for each incoming message. -- diff --git a/services/brig/src/Brig/Schema/Run.hs b/services/brig/src/Brig/Schema/Run.hs index cf9b27a2eb9..f833b8d97b1 100644 --- a/services/brig/src/Brig/Schema/Run.hs +++ b/services/brig/src/Brig/Schema/Run.hs @@ -59,6 +59,7 @@ import Brig.Schema.V81_AddFederationRemoteTeams qualified as V81_AddFederationRe import Brig.Schema.V82_DropPhoneColumn qualified as V82_DropPhoneColumn import Brig.Schema.V83_AddTextStatus qualified as V83_AddTextStatus import Brig.Schema.V84_DropTeamInvitationPhone qualified as V84_DropTeamInvitationPhone +import Brig.Schema.V85_DropUserKeysHashed qualified as V85_DropUserKeysHashed import Cassandra.MigrateSchema (migrateSchema) import Cassandra.Schema import Control.Exception (finally) @@ -124,9 +125,8 @@ migrations = V81_AddFederationRemoteTeams.migration, V82_DropPhoneColumn.migration, V83_AddTextStatus.migration, - V84_DropTeamInvitationPhone.migration + V84_DropTeamInvitationPhone.migration, + V85_DropUserKeysHashed.migration -- FUTUREWORK: undo V41 (searchable flag); we stopped using it in -- https://github.com/wireapp/wire-server/pull/964 - -- - -- FUTUREWORK after July 2023: integrate V_FUTUREWORK here. ] diff --git a/services/brig/src/Brig/Schema/V_FUTUREWORK.hs b/services/brig/src/Brig/Schema/V85_DropUserKeysHashed.hs similarity index 82% rename from services/brig/src/Brig/Schema/V_FUTUREWORK.hs rename to services/brig/src/Brig/Schema/V85_DropUserKeysHashed.hs index d4e00c4ec19..22e4879a247 100644 --- a/services/brig/src/Brig/Schema/V_FUTUREWORK.hs +++ b/services/brig/src/Brig/Schema/V85_DropUserKeysHashed.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Schema.V_FUTUREWORK +module Brig.Schema.V85_DropUserKeysHashed ( migration, ) where @@ -36,13 +36,9 @@ import Text.RawString.QQ -- backwards-incompatbile schema migration docs in -- https://docs.wire.com/developer/developer/cassandra-interaction.html?highlight=backwards+incompatbile#backwards-incompatible-schema-changes -- --- FUTUREWORK: remove futurework_number and replace its usage by the next matching number after July 2023, rename this module with a version number, and --- integrate it inside Main.hs and App.hs -futureworkNumber :: Int32 -futureworkNumber = undefined migration :: Migration -migration = Migration futureworkNumber "Drop deprecated user_keys_hashed table" $ do +migration = Migration 85 "Drop deprecated user_keys_hashed table" $ do schema' [r| DROP TABLE IF EXISTS user_keys_hash diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 07b38e1a57b..f13582fd6f4 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -22,7 +22,6 @@ module Brig.Team.Email CreatorWelcomeEmail (..), MemberWelcomeEmail (..), sendInvitationMail, - sendCreatorWelcomeMail, sendMemberWelcomeMail, ) where @@ -50,13 +49,6 @@ sendInvitationMail to tid from code loc = do let mail = InvitationEmail to tid code from liftSem $ sendMail $ renderInvitationEmail mail tpl branding -sendCreatorWelcomeMail :: (Member EmailSending r) => Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () -sendCreatorWelcomeMail to tid teamName loc = do - tpl <- creatorWelcomeEmail . snd <$> teamTemplates loc - branding <- view templateBranding - let mail = CreatorWelcomeEmail to tid teamName - liftSem $ sendMail $ renderCreatorWelcomeMail mail tpl branding - sendMemberWelcomeMail :: (Member EmailSending r) => Email -> TeamId -> Text -> Maybe Locale -> (AppT r) () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplates loc @@ -113,28 +105,6 @@ data CreatorWelcomeEmail = CreatorWelcomeEmail cwTeamName :: !Text } -renderCreatorWelcomeMail :: CreatorWelcomeEmail -> CreatorWelcomeEmailTemplate -> TemplateBranding -> Mail -renderCreatorWelcomeMail CreatorWelcomeEmail {..} CreatorWelcomeEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "Welcome") - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - from = Address (Just creatorWelcomeEmailSenderName) (fromEmail creatorWelcomeEmailSender) - to = Address Nothing (fromEmail cwTo) - txt = renderTextWithBranding creatorWelcomeEmailBodyText replace branding - html = renderHtmlWithBranding creatorWelcomeEmailBodyHtml replace branding - subj = renderTextWithBranding creatorWelcomeEmailSubject replace branding - replace "url" = creatorWelcomeEmailUrl - replace "email" = fromEmail cwTo - replace "team_id" = idToText cwTid - replace "team_name" = cwTeamName - replace x = x - ------------------------------------------------------------------------------- -- Member Welcome Email diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index e1204c43bfd..23ed4c461bf 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -31,7 +31,6 @@ module Brig.User.Auth.Cookie newCookieLimited, -- * HTTP - setResponseCookie, toWebCookie, -- * Re-exports @@ -55,8 +54,6 @@ import Data.Proxy import Data.RetryAfter import Data.Time.Clock import Imports -import Network.Wai (Response) -import Network.Wai.Utilities.Response (addHeader) import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -264,15 +261,6 @@ newCookieLimited u c typ label = do -------------------------------------------------------------------------------- -- HTTP -setResponseCookie :: - (MonadReader Env m, ZAuth.UserTokenLike u) => - Cookie (ZAuth.Token u) -> - Response -> - m Response -setResponseCookie c r = do - hdr <- toByteString' . WebCookie.renderSetCookie <$> toWebCookie c - pure (addHeader "Set-Cookie" hdr r) - toWebCookie :: (MonadReader Env m, ZAuth.UserTokenLike u) => Cookie (ZAuth.Token u) -> m WebCookie.SetCookie toWebCookie c = do s <- view settings diff --git a/services/brig/src/Brig/ZAuth.hs b/services/brig/src/Brig/ZAuth.hs index 9eaf2cba30a..512e1251b98 100644 --- a/services/brig/src/Brig/ZAuth.hs +++ b/services/brig/src/Brig/ZAuth.hs @@ -77,7 +77,6 @@ module Brig.ZAuth userTokenRand, tokenExpires, tokenExpiresUTC, - tokenKeyIndex, zauthType, -- * Re-exports @@ -444,9 +443,6 @@ userTokenRand' t = t ^. body . rand legalHoldUserTokenRand :: Token LegalHoldUser -> Word32 legalHoldUserTokenRand t = t ^. body . legalHoldUser . rand -tokenKeyIndex :: Token a -> Int -tokenKeyIndex t = t ^. header . key - tokenExpires :: Token a -> POSIXTime tokenExpires t = fromIntegral (t ^. header . time) diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 5e6c4856d96..0a3789a9d47 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -23,7 +23,6 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert -import Brig.Options (Opts) import Brig.ZAuth (Token) import Cassandra qualified as DB import Codec.MIME.Type qualified as MIME @@ -48,7 +47,6 @@ import Data.String.Conversions import Data.Text.Ascii qualified as Ascii import Data.Vector qualified as Vec import Data.ZAuth.Token qualified as ZAuth -import Federation.Util (withTempMockFederator) import GHC.TypeLits (KnownSymbol) import Imports import Test.Tasty.Cannon qualified as WS @@ -372,23 +370,6 @@ receiveConnectionAction brig fedBrigClient uid1 quid2 action expectedReaction ex res @?= F.NewConnectionResponseOk expectedReaction assertConnectionQualified brig uid1 quid2 expectedRel -sendConnectionUpdateAction :: - (HasCallStack) => - Brig -> - Opts -> - UserId -> - Qualified UserId -> - Maybe F.RemoteConnectionAction -> - Relation -> - Http () -sendConnectionUpdateAction brig opts uid1 quid2 reaction expectedRel = do - let mockConnectionResponse = F.NewConnectionResponseOk reaction - mockResponse = encode mockConnectionResponse - void $ - liftIO . withTempMockFederator opts mockResponse $ - putConnectionQualified brig uid1 quid2 expectedRel !!! const 200 === statusCode - assertConnectionQualified brig uid1 quid2 expectedRel - assertEmailVisibility :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> Bool -> m () assertEmailVisibility brig a b visible = get (apiVersion "v1" . brig . paths ["users", pack . show $ userId b] . zUser (userId a)) !!! do diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index ace4d04fbbe..a1cc7edb483 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -116,32 +116,3 @@ connectUsersEnd2End brig1 brig2 quid1 quid2 = do !!! const 201 === statusCode putConnectionQualified brig2 (qUnqualified quid2) quid1 Accepted !!! const 200 === statusCode - -sendCommitBundle :: (HasCallStack) => FilePath -> FilePath -> Maybe FilePath -> Galley -> UserId -> ClientId -> ByteString -> Http () -sendCommitBundle tmp subGroupStateFn welcomeFn galley uid cid commit = do - subGroupStateRaw <- liftIO $ BS.readFile $ tmp subGroupStateFn - subGroupState <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ subGroupStateRaw - subCommit <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ commit - mbWelcome <- - for - welcomeFn - $ \fn -> do - bs <- liftIO $ BS.readFile $ tmp fn - msg :: Message <- either (liftIO . assertFailure . T.unpack) pure . decodeMLS' $ bs - case msg.content of - MessageWelcome welcome -> pure welcome - _ -> liftIO . assertFailure $ "Expected a welcome" - - let subGroupBundle = CommitBundle subCommit mbWelcome subGroupState - post - ( galley - . paths - ["mls", "commit-bundles"] - . zUser uid - . zClient cid - . zConn "conn" - . header "Z-Type" "access" - . Bilge.content "message/mls" - . lbytes (encodeMLS subGroupBundle) - ) - !!! const 201 === statusCode diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 05984cedcb1..fe86d2c2d8b 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -27,7 +27,7 @@ import Cannon.API.Public import Cannon.App (maxPingInterval) import Cannon.Dict qualified as D import Cannon.Options -import Cannon.Types (Cannon, applog, clients, env, mkEnv, runCannon', runCannonToServant) +import Cannon.Types (Cannon, applog, clients, env, mkEnv, runCannon, runCannonToServant) import Cannon.WS hiding (env) import Control.Concurrent import Control.Concurrent.Async qualified as Async @@ -74,7 +74,7 @@ run o = do <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock - refreshMetricsThread <- Async.async $ runCannon' e refreshMetrics + refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) let middleware :: Wai.Middleware diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index e085a0d9f20..eec8d20ac4b 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -23,13 +23,10 @@ module Cannon.Types applog, dict, env, - logger, Cannon, mapConcurrentlyCannon, mkEnv, runCannon, - runCannon', - options, clients, wsenv, runCannonToServant, @@ -47,9 +44,6 @@ import Control.Lens ((^.)) import Control.Monad.Catch import Data.Text.Encoding import Imports -import Network.Wai -import Network.Wai.Utilities.Request qualified as Wai -import Network.Wai.Utilities.Server import Prometheus import Servant qualified import System.Logger qualified as Logger @@ -109,17 +103,8 @@ mkEnv external o l d p g t = Env o l d (RequestId "N/A") $ WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) -runCannon :: Env -> Cannon a -> Request -> IO a -runCannon e c r = do - let rid = Wai.getRequestId defaultRequestIdHeaderName r - e' = e {reqId = rid} - runCannon' e' c - -runCannon' :: Env -> Cannon a -> IO a -runCannon' e c = runReaderT (unCannon c) e - -options :: Cannon Opts -options = Cannon $ asks opts +runCannon :: Env -> Cannon a -> IO a +runCannon e c = runReaderT (unCannon c) e clients :: Cannon (Dict Key Websocket) clients = Cannon $ asks dict @@ -130,10 +115,7 @@ wsenv = Cannon $ do r <- asks reqId pure $ WS.setRequestId r e -logger :: Cannon Logger -logger = Cannon $ asks applog - -- | Natural transformation from 'Cannon' to 'Handler' monad. -- Used to call 'Cannon' from servant. runCannonToServant :: Cannon.Types.Env -> Cannon x -> Servant.Handler x -runCannonToServant env c = liftIO $ runCannon' env c +runCannonToServant env c = liftIO $ runCannon env c diff --git a/services/cargohold/src/CargoHold/API/Error.hs b/services/cargohold/src/CargoHold/API/Error.hs index 4fed14f95bd..ef38babfe79 100644 --- a/services/cargohold/src/CargoHold/API/Error.hs +++ b/services/cargohold/src/CargoHold/API/Error.hs @@ -41,34 +41,6 @@ unverifiedUser = errorToWai @'UnverifiedUser userNotFound :: Error userNotFound = errorToWai @'UserNotFound -invalidMD5 :: Error -invalidMD5 = mkError status400 "client-error" "Invalid MD5." - -requestTimeout :: Error -requestTimeout = - mkError - status408 - "request-timeout" - "The request timed out. The server was still expecting more data \ - \but none was sent over an extended period of time. Idle connections \ - \will be closed." - -uploadTooSmall :: Error -uploadTooSmall = - mkError - status403 - "client-error" - "The current chunk size is \ - \smaller than the minimum allowed." - -uploadTooLarge :: Error -uploadTooLarge = - mkError - status413 - "client-error" - "The current chunk size + offset \ - \is larger than the full upload size." - noMatchingAssetEndpoint :: Error noMatchingAssetEndpoint = errorToWai @'NoMatchingAssetEndpoint diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index 587937d7aa2..29aa2750f44 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -32,7 +32,6 @@ module CargoHold.AWS amazonkaDownloadEndpoint, -- * AWS - send, sendCatch, exec, execStream, @@ -164,16 +163,6 @@ sendCatch :: m (Either AWS.Error (AWSResponse r)) sendCatch env = AWS.trying AWS._Error . AWS.send env -send :: - (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => - AWS.Env -> - r -> - Amazon (AWSResponse r) -send env r = throwA =<< sendCatch env r - -throwA :: Either AWS.Error a -> Amazon a -throwA = either (throwM . GeneralError) pure - exec :: ( AWSRequest r, Typeable r, diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 85c31799667..e40d499915b 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -39,7 +39,6 @@ module CargoHold.App AppT, App, runAppT, - runAppResourceT, executeBrigInteral, -- * Handler Monad @@ -59,7 +58,6 @@ import Control.Error (ExceptT, exceptT) import Control.Exception (throw) import Control.Lens (Lens', makeLenses, non, view, (?~), (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) import qualified Data.Map as Map import Data.Qualified import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) @@ -233,9 +231,6 @@ instance HasRequestId (ExceptT e App) where runAppT :: Env -> AppT m a -> m a runAppT e (AppT a) = runReaderT a e -runAppResourceT :: (MonadIO m) => Env -> ResourceT App a -> m a -runAppResourceT e rma = liftIO . runResourceT $ transResourceT (runAppT e) rma - executeBrigInteral :: BrigInternalClient a -> App (Either Servant.ClientError a) executeBrigInteral action = do httpMgr <- view httpManager diff --git a/services/federator/src/Federator/Error.hs b/services/federator/src/Federator/Error.hs index 7b6f06342d9..28d52c18a9e 100644 --- a/services/federator/src/Federator/Error.hs +++ b/services/federator/src/Federator/Error.hs @@ -17,17 +17,10 @@ module Federator.Error ( AsWai (..), - errorResponse, ) where -import Data.Aeson qualified as A -import Network.HTTP.Types.Header -import Network.Wai qualified as Wai import Network.Wai.Utilities.Error qualified as Wai class AsWai e where toWai :: e -> Wai.Error - -errorResponse :: [Header] -> Wai.Error -> Wai.Response -errorResponse hdrs e = Wai.responseLBS (Wai.code e) hdrs (A.encode e) diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index 38c315a6498..362c081d4ed 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -18,7 +18,6 @@ module Federator.Validation ( ensureCanFederateWith, parseDomain, - parseDomainText, decodeCertificate, validateDomain, validateDomainName, @@ -127,13 +126,6 @@ parseDomain domain = note (DomainParseError (Text.decodeUtf8With Text.lenientDecode domain)) $ fromByteString domain -parseDomainText :: (Member (Error ValidationError) r) => Text -> Sem r Domain -parseDomainText domain = - mapError @String (const (DomainParseError domain)) - . fromEither - . mkDomain - $ domain - -- | Validates an unknown domain string against the allow list using the -- federator startup configuration and checks that it matches the names reported -- by the client certificate diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index 92d80d7d752..76f8e31dca4 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -182,22 +182,15 @@ randomUser' :: m User randomUser' hasPwd brig = do n <- fromName <$> randomName - createUser' hasPwd n brig + createUser hasPwd n brig createUser :: - (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => - Text -> - BrigReq -> - m User -createUser = createUser' True - -createUser' :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Bool -> Text -> BrigReq -> m User -createUser' hasPwd name brig = do +createUser hasPwd name brig = do r <- postUser' hasPwd True name True False Nothing Nothing brig extraTargets) action' --- | Similar to 'updateLocalConversationUnchecked', but skips performing --- user authorisation checks. This is written for use in de-federation code --- where conversations for many users will be torn down at once and must work. --- --- Additionally, this function doesn't make notification calls to clients. -updateLocalConversationUserUnchecked :: - forall tag r. - ( SingI tag, - HasConversationActionEffects tag r, - Member BackendNotificationQueueAccess r, - Member (Error FederationError) r - ) => - Local Conversation -> - Qualified UserId -> - ConversationAction tag -> - Sem r () -updateLocalConversationUserUnchecked lconv qusr action = do - let tag = sing @tag - - -- perform action - void $ performAction tag qusr lconv action - -- -------------------------------------------------------------------------------- -- -- Utilities diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 04423558a2f..5ece86d0a4f 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -25,9 +25,6 @@ module Galley.API.Error internalErrorWithDescription, internalErrorDescription, legalHoldServiceUnavailable, - - -- * Errors thrown by wai-routing handlers - invalidTeamNotificationId, ) where @@ -101,6 +98,3 @@ badConvState cid = legalHoldServiceUnavailable :: (Show a) => a -> Wai.Error legalHoldServiceUnavailable e = Wai.mkError status412 "legalhold-unavailable" ("legal hold service unavailable with underlying error: " <> (LT.pack . show $ e)) - -invalidTeamNotificationId :: Wai.Error -invalidTeamNotificationId = Wai.mkError status400 "invalid-notification-id" "Could not parse notification id (must be UUIDv1)." diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index aab4029df73..ee913e41c13 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -824,7 +824,7 @@ onMLSMessageSent domain rmm = ByteString ) let recipients = - filter (\r -> Set.member (_recipientUserId r) members) + filter (\r -> Set.member (recipientUserId r) members) . map (\(u, clts) -> Recipient u (RecipientClientsSome (List1 clts))) . Map.assocs $ rmm.recipients diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index 3274956f1bd..76745094c1f 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -207,9 +207,3 @@ instance HasField "id" ConvOrSubConv ConvOrSubConvId where instance HasField "migrationState" ConvOrSubConv MLSMigrationState where getField (Conv c) = c.mcMigrationState getField (SubConv _ _) = MLSMigrationMLS - -convOrSubConvActivate :: ActiveMLSConversationData -> ConvOrSubConv -> ConvOrSubConv -convOrSubConvActivate activeData (Conv c) = - Conv $ c {mcMLSData = (mcMLSData c) {cnvmlsActiveData = Just activeData}} -convOrSubConvActivate activeData (SubConv c s) = - SubConv c $ s {scMLSData = (scMLSData s) {cnvmlsActiveData = Just activeData}} diff --git a/services/galley/src/Galley/API/Push.hs b/services/galley/src/Galley/API/Push.hs index c66a8ae73a4..5d379999bf0 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -69,7 +69,7 @@ newMessagePush :: Event -> MessagePush newMessagePush botMap mconn mm userOrBots event = - let toPair r = case Map.lookup (_recipientUserId r) botMap of + let toPair r = case Map.lookup (recipientUserId r) botMap of Just botMember -> ([], [botMember]) Nothing -> ([r], []) (recipients, botMembers) = foldMap (toPair . toRecipient) userOrBots diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index b87dcf5e051..cc0332b22a1 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -22,7 +22,6 @@ module Galley.API.Util where import Control.Lens (set, view, (.~), (^.)) import Control.Monad.Extra (allM, anyM) import Data.Bifunctor -import Data.ByteString.Conversion import Data.Code qualified as Code import Data.Domain (Domain) import Data.Id as Id @@ -38,7 +37,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Text qualified as T import Data.Time -import GHC.TypeLits import Galley.API.Error import Galley.API.Mapping import Galley.Data.Conversation qualified as Data @@ -64,14 +62,10 @@ import Galley.Types.UserList import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding (forkIO) import Network.AMQP qualified as Q -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Utilities qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P -import System.Logger qualified as Log import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -520,9 +514,6 @@ localBotsAndUsers = foldMap botOrUser Just _ -> (toList (newBotMember m), []) Nothing -> ([], [m]) -location :: (ToByteString a) => a -> Response -> Response -location = Wai.addHeader hLocation . toByteString' - nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember] nonTeamMembers cm tm = filter (not . isMemberOfTeam . lmId) cm where @@ -1089,13 +1080,3 @@ instance if err' == demote @e then throwS @e else rethrowErrors @effs @r err' - -logRemoteNotificationError :: - forall rpc r. - (Member P.TinyLog r, KnownSymbol rpc) => - FederationError -> - Sem r () -logRemoteNotificationError e = - P.warn $ - Log.field "federation call" (symbolVal (Proxy @rpc)) - . Log.msg (displayException e) diff --git a/services/galley/src/Galley/Cassandra/Access.hs b/services/galley/src/Galley/Cassandra/Access.hs index 05c566bfd11..3d196cd54c2 100644 --- a/services/galley/src/Galley/Cassandra/Access.hs +++ b/services/galley/src/Galley/Cassandra/Access.hs @@ -32,6 +32,3 @@ defAccess ConnectConv (Just (Set [])) = [PrivateAccess] defAccess One2OneConv (Just (Set [])) = [PrivateAccess] defAccess RegularConv (Just (Set [])) = defRegularConvAccess defAccess _ (Just (Set (x : xs))) = x : xs - -privateOnly :: Set Access -privateOnly = Set [PrivateAccess] diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index fa8c5c89042..309996486b6 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -234,9 +234,6 @@ selectConv :: ) selectConv = "select type, creator, access, access_role, access_roles_v2, name, team, deleted, message_timer, receipt_mode, protocol, group_id, epoch, WRITETIME(epoch), cipher_suite from conversation where conv = ?" -selectReceiptMode :: PrepQuery R (Identity ConvId) (Identity (Maybe ReceiptMode)) -selectReceiptMode = "select receipt_mode from conversation where conv = ?" - isConvDeleted :: PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) isConvDeleted = "select deleted from conversation where conv = ?" @@ -364,9 +361,6 @@ insertCipherSuiteForSubConversation = "UPDATE subconversation set cipher_suite = listSubConversations :: PrepQuery R (Identity ConvId) (SubConvId, CipherSuiteTag, Epoch, Writetime Epoch, GroupId) listSubConversations = "SELECT subconv_id, cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ?" -selectSubConversations :: PrepQuery R (Identity ConvId) (Identity SubConvId) -selectSubConversations = "SELECT subconv_id FROM subconversation WHERE conv_id = ?" - deleteSubConversation :: PrepQuery W (ConvId, SubConvId) () deleteSubConversation = "DELETE FROM subconversation where conv_id = ? and subconv_id = ?" @@ -460,9 +454,6 @@ updateRemoteOtrMemberArchived = {- `IF EXISTS`, but that requires benchmarking - updateRemoteMemberHidden :: PrepQuery W (Bool, Maybe Text, Domain, ConvId, UserId) () updateRemoteMemberHidden = {- `IF EXISTS`, but that requires benchmarking -} "update user_remote_conv set hidden = ?, hidden_ref = ? where conv_remote_domain = ? and conv_remote_id = ? and user = ?" -selectRemoteMemberStatus :: PrepQuery R (Domain, ConvId, UserId) (Maybe MutedStatus, Maybe Text, Maybe Bool, Maybe Text, Maybe Bool, Maybe Text) -selectRemoteMemberStatus = "select otr_muted_status, otr_muted_ref, otr_archived, otr_archived_ref, hidden, hidden_ref from user_remote_conv where conv_remote_domain = ? and conv_remote_id = ? and user = ?" - -- Clients ------------------------------------------------------------------ selectClients :: PrepQuery R (Identity [UserId]) (UserId, C.Set ClientId) diff --git a/services/galley/src/Galley/Data/Conversation.hs b/services/galley/src/Galley/Data/Conversation.hs index fe18548b2c0..aeec69ae609 100644 --- a/services/galley/src/Galley/Data/Conversation.hs +++ b/services/galley/src/Galley/Data/Conversation.hs @@ -27,7 +27,6 @@ module Galley.Data.Conversation convAccess, convAccessData, convAccessRoles, - convCreator, convMessageTimer, convName, convReceiptMode, @@ -86,9 +85,6 @@ convAccessData c = (Set.fromList (convAccess c)) (convAccessRoles c) -convCreator :: Conversation -> Maybe UserId -convCreator = cnvmCreator . convMetadata - convName :: Conversation -> Maybe Text convName = cnvmName . convMetadata diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index eaa5e70ba01..73ab4ca9844 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -25,7 +25,6 @@ module Galley.Effects.FederatorAccess runFederatedConcurrently, runFederatedConcurrentlyEither, runFederatedConcurrentlyBucketsEither, - runFederatedConcurrently_, isFederationConfigured, ) where @@ -71,10 +70,3 @@ data FederatorAccess m a where IsFederationConfigured :: FederatorAccess m Bool makeSem ''FederatorAccess - -runFederatedConcurrently_ :: - (KnownComponent c, Foldable f, Functor f, Member FederatorAccess r) => - f (Remote a) -> - (Remote [a] -> FederatorClient c x) -> - Sem r () -runFederatedConcurrently_ xs = void . runFederatedConcurrently xs diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 0ebff1f349f..8947d4a7a4a 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -18,7 +18,6 @@ module Galley.Intra.Util ( IntraComponent (..), call, - asyncCall, ) where @@ -27,7 +26,6 @@ import Bilge qualified as B import Bilge.RPC import Bilge.Retry import Control.Lens (view, (^.)) -import Control.Monad.Catch import Control.Retry import Data.ByteString.Lazy qualified as LB import Data.Misc (portNumber) @@ -38,8 +36,6 @@ import Galley.Monad import Galley.Options import Imports hiding (log) import Network.HTTP.Types -import System.Logger -import System.Logger.Class qualified as LC import Util.Options data IntraComponent = Brig | Spar | Gundeck @@ -79,15 +75,5 @@ call comp r = do let n = LT.pack (componentName comp) recovering (componentRetryPolicy comp) rpcHandlers (const (rpc n (r . r0))) -asyncCall :: IntraComponent -> (Request -> Request) -> App () -asyncCall comp req = void $ do - let n = LT.pack (componentName comp) - forkIO $ catches (void (call comp req)) (handlers n) - where - handlers n = - [ Handler $ \(x :: RPCException) -> LC.err (rpcExceptionMsg x), - Handler $ \(x :: SomeException) -> LC.err $ "remote" .= n ~~ msg (show x) - ] - x1 :: RetryPolicy x1 = limitRetries 1 diff --git a/services/galley/src/Galley/Types/Clients.hs b/services/galley/src/Galley/Types/Clients.hs index 4992b1aaaf3..8c4d925f3cd 100644 --- a/services/galley/src/Galley/Types/Clients.hs +++ b/services/galley/src/Galley/Types/Clients.hs @@ -19,21 +19,12 @@ module Galley.Types.Clients ( Clients, - userIds, clientIds, toList, fromList, fromUserClients, toMap, - fromMap, - singleton, - insert, - diff, - filter, contains, - Galley.Types.Clients.null, - Galley.Types.Clients.nil, - rmClient, ) where @@ -54,15 +45,6 @@ instance Bounds Clients where let n = Map.size ((userClients . clients) c) in n >= fromIntegral x && n <= fromIntegral y -null :: Clients -> Bool -null = Map.null . (userClients . clients) - -nil :: Clients -nil = Clients $ UserClients Map.empty - -userIds :: Clients -> [UserId] -userIds = Map.keys . (userClients . clients) - clientIds :: UserId -> Clients -> [ClientId] clientIds u c = Set.toList $ fromMaybe Set.empty (Map.lookup u ((userClients . clients) c)) @@ -79,44 +61,9 @@ fromList = Clients . UserClients . foldr fn Map.empty fromUserClients :: UserClients -> Clients fromUserClients = Clients -fromMap :: Map UserId (Set ClientId) -> Clients -fromMap = Clients . UserClients - toMap :: Clients -> Map UserId (Set ClientId) toMap = userClients . clients -singleton :: UserId -> [ClientId] -> Clients -singleton u c = - Clients . UserClients $ Map.singleton u (Set.fromList c) - -filter :: (UserId -> Bool) -> Clients -> Clients -filter p = - Clients - . UserClients - . Map.filterWithKey (\u _ -> p u) - . (userClients . clients) - contains :: UserId -> ClientId -> Clients -> Bool contains u c = maybe False (Set.member c) . Map.lookup u . (userClients . clients) - -insert :: UserId -> ClientId -> Clients -> Clients -insert u c = - Clients - . UserClients - . Map.insertWith Set.union u (Set.singleton c) - . (userClients . clients) - -diff :: Clients -> Clients -> Clients -diff (Clients (UserClients ca)) (Clients (UserClients cb)) = - Clients . UserClients $ Map.differenceWith fn ca cb - where - fn a b = - let d = a `Set.difference` b - in if Set.null d then Nothing else Just d - -rmClient :: UserId -> ClientId -> Clients -> Clients -rmClient u c (Clients (UserClients m)) = - Clients . UserClients $ Map.update f u m - where - f x = let s = Set.delete c x in if Set.null s then Nothing else Just s diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 978f7ab4d14..fd0f371a2d2 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -757,43 +757,6 @@ readWelcome fp = runMaybeT $ do guard $ fileSize stat > 0 liftIO $ BS.readFile fp -createRemoveCommit :: (HasCallStack) => ClientIdentity -> [ClientIdentity] -> MLSTest MessagePackage -createRemoveCommit cid targets = do - bd <- State.gets mlsBaseDir - welcomeFile <- liftIO $ emptyTempFile bd "welcome" - pgsFile <- liftIO $ emptyTempFile bd "pgs" - - g <- getClientGroupState cid - - let groupStateMap = Map.fromList (readGroupState g) - let indices = map (fromMaybe (error "could not find target") . flip Map.lookup groupStateMap) targets - commit <- - mlscli - cid - ( [ "member", - "remove", - "--group", - "", - "--group-out", - "", - "--welcome-out", - welcomeFile, - "--group-info-out", - pgsFile - ] - <> map show indices - ) - Nothing - welcome <- liftIO $ readWelcome welcomeFile - pgs <- liftIO $ BS.readFile pgsFile - pure - MessagePackage - { mpSender = cid, - mpMessage = commit, - mpWelcome = welcome, - mpGroupInfo = Just pgs - } - createExternalAddProposal :: (HasCallStack) => ClientIdentity -> MLSTest MessagePackage createExternalAddProposal joiner = do groupId <- diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 8e6d49e3d21..ea775d4b40e 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -59,7 +59,6 @@ import Data.Qualified import Data.Range import Data.Serialize (runPut) import Data.Set qualified as Set -import Data.Singletons import Data.String.Conversions import Data.Text qualified as Text import Data.Text.Encoding qualified as T @@ -96,14 +95,12 @@ import Web.Cookie import Wire.API.Connection import Wire.API.Conversation import Wire.API.Conversation qualified as Conv -import Wire.API.Conversation.Action import Wire.API.Conversation.Code hiding (Value) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Conversation.Typing import Wire.API.Event.Conversation import Wire.API.Event.Conversation qualified as Conv -import Wire.API.Event.Federation qualified as Fed import Wire.API.Event.LeaveReason import Wire.API.Event.Team import Wire.API.Event.Team qualified as TE @@ -1695,10 +1692,6 @@ assertMLSMessageEvent qcs u message e = do evtFrom e @?= u evtData e @?= EdMLSMessage message --- | This assumes the default role name -wsAssertMemberJoin :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> Notification -> IO () -wsAssertMemberJoin conv usr new = wsAssertMemberJoinWithRole conv usr new roleNameWireAdmin - wsAssertMemberJoinWithRole :: (HasCallStack) => Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> RoleName -> Notification -> IO () wsAssertMemberJoinWithRole conv usr new role n = do let e = List1.head (WS.unpackPayload n) @@ -1712,23 +1705,6 @@ assertJoinEvent conv usr new role e = do evtFrom e @?= usr fmap (sort . mMembers) (evtData e ^? _EdMembersJoin) @?= Just (sort (fmap (`SimpleMember` role) new)) -wsAssertFederationDeleted :: - (HasCallStack) => - Domain -> - Notification -> - IO () -wsAssertFederationDeleted dom n = do - ntfTransient n @?= False - assertFederationDeletedEvent dom $ List1.head (WS.unpackPayload n) - -assertFederationDeletedEvent :: - Domain -> - Fed.Event -> - IO () -assertFederationDeletedEvent dom e = do - Fed._eventType e @?= Fed.FederationDelete - Fed._eventDomain e @?= dom - -- FUTUREWORK: See if this one can be implemented in terms of: -- -- checkConvMemberLeaveEvent :: HasCallStack => Qualified ConvId -> Qualified UserId -> WS.WebSocket -> TestM () @@ -1817,29 +1793,6 @@ assertNoMsg ws f = do Left _ -> pure () -- expected Right _ -> assertFailure "Unexpected message" -assertRemoveUpdate :: (MonadIO m, HasCallStack) => FederatedRequest -> Qualified ConvId -> Qualified UserId -> [UserId] -> Qualified UserId -> m () -assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do - frRPC req @?= "on-conversation-updated" - frOriginDomain req @?= qDomain qconvId - cu <- assertJust $ decode (frBody req) - cuOrigUserId cu @?= remover - cuConvId cu @?= qUnqualified qconvId - sort (cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - cuAction cu - @?= SomeConversationAction - (sing @'ConversationRemoveMembersTag) - (ConversationRemoveMembers (pure victim) EdReasonRemoved) - -assertLeaveUpdate :: (MonadIO m, HasCallStack) => FederatedRequest -> Qualified ConvId -> Qualified UserId -> [UserId] -> m () -assertLeaveUpdate req qconvId remover alreadyPresentUsers = liftIO $ do - frRPC req @?= "on-conversation-updated" - frOriginDomain req @?= qDomain qconvId - cu <- assertJust $ decode (frBody req) - cuOrigUserId cu @?= remover - cuConvId cu @?= qUnqualified qconvId - sort (cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - cuAction cu @?= SomeConversationAction (sing @'ConversationLeaveTag) () - ------------------------------------------------------------------------------- -- Helpers @@ -1873,15 +1826,9 @@ decodeConvId = qUnqualified . decodeQualifiedConvId decodeQualifiedConvId :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> Qualified ConvId decodeQualifiedConvId = cnvQualifiedId . responseJsonUnsafe -decodeConvList :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> [Conversation] -decodeConvList = convList . responseJsonUnsafeWithMsg "conversations" - decodeConvIdList :: (HasCallStack) => Response (Maybe Lazy.ByteString) -> [ConvId] decodeConvIdList = convList . responseJsonUnsafeWithMsg "conversation-ids" -decodeQualifiedConvIdList :: Response (Maybe Lazy.ByteString) -> Either String [Qualified ConvId] -decodeQualifiedConvIdList = fmap mtpResults . responseJsonEither @ConvIdsPage - zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' diff --git a/services/galley/test/integration/Federation.hs b/services/galley/test/integration/Federation.hs index 666c557ad7d..c2fd087ce73 100644 --- a/services/galley/test/integration/Federation.hs +++ b/services/galley/test/integration/Federation.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE RecordWildCards #-} - module Federation where -import Cassandra qualified as C import Control.Lens ((^.)) import Control.Monad.Catch -import Data.ByteString qualified as LBS import Data.Domain import Data.Id import Data.Qualified -import Data.Set qualified as Set import Data.UUID qualified as UUID import Galley.API.Util import Galley.App @@ -21,15 +16,8 @@ import Test.Tasty.HUnit import TestSetup import UnliftIO.Retry import Wire.API.Conversation -import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Protocol (Protocol (..)) import Wire.API.Conversation.Role (roleNameWireMember) -import Wire.API.Routes.FederationDomainConfig -import Wire.API.Routes.MultiTablePaging -import Wire.API.Routes.MultiTablePaging qualified as Public - -x3 :: RetryPolicy -x3 = limitRetries 3 <> exponentialBackoff 100000 isConvMemberLTests :: TestM () isConvMemberLTests = do @@ -60,16 +48,5 @@ isConvMemberLTests = do liftIO $ assertBool "Qualified UserId (local)" $ isConvMemberL lconv $ tUntagged lUserId liftIO $ assertBool "Qualified UserId (remote)" $ isConvMemberL lconv $ tUntagged rUserId -fromFedList :: FederationDomainConfigs -> Set Domain -fromFedList = Set.fromList . fmap domain . remotes - constHandlers :: (MonadIO m) => [RetryStatus -> Handler m Bool] constHandlers = [const $ Handler $ (\(_ :: SomeException) -> pure True)] - -pageToConvIdPage :: Public.LocalOrRemoteTable -> C.PageWithState (Qualified ConvId) -> Public.ConvIdsPage -pageToConvIdPage table page@C.PageWithState {..} = - Public.MultiTablePage - { mtpResults = pwsResults, - mtpHasMore = C.pwsHasMore page, - mtpPagingState = Public.ConversationPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) - } diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index 944a9d213bf..21d4ada077b 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -46,7 +46,6 @@ module Gundeck.Aws Attributes, AWS.Seconds (..), publish, - timeToLive, -- * Feedback listen, @@ -383,26 +382,6 @@ newtype Attributes = Attributes -- -- cf. http://docs.aws.amazon.com/sns/latest/dg/sns-ttl.html -timeToLive :: Transport -> AWS.Seconds -> Attributes -timeToLive t s = Attributes (Endo (ttlAttr s)) - where - ttlAttr n - | n == 0 = setTTL (ttlNow t) - | otherwise = setTTL (toText n) - setTTL v = - let ty = SNS.newMessageAttributeValue "String" - in Map.insert (ttlKey t) (ty & SNS.messageAttributeValue_stringValue ?~ v) - ttlNow GCM = "0" - ttlNow APNS = "0" - ttlNow APNSSandbox = "0" - ttlNow APNSVoIP = "15" -- See note [VoIP TTLs] - ttlNow APNSVoIPSandbox = "15" -- See note [VoIP TTLs] - ttlKey GCM = "AWS.SNS.MOBILE.GCM.TTL" - ttlKey APNS = "AWS.SNS.MOBILE.APNS.TTL" - ttlKey APNSSandbox = "AWS.SNS.MOBILE.APNS_SANDBOX.TTL" - ttlKey APNSVoIP = "AWS.SNS.MOBILE.APNS_VOIP.TTL" - ttlKey APNSVoIPSandbox = "AWS.SNS.MOBILE.APNS_VOIP_SANDBOX.TTL" - publish :: EndpointArn -> LT.Text -> Attributes -> Amazon (Either PublishError ()) publish arn txt attrs = do -- TODO: Make amazonka accept a lazy text or bytestring. diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 8fc8b78abaf..e3d1fcbe148 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -62,9 +62,6 @@ data Env = Env makeLenses ''Env -schemaVersion :: Int32 -schemaVersion = 7 - createEnv :: Opts -> IO ([Async ()], Env) createEnv o = do l <- Logger.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) diff --git a/services/gundeck/src/Gundeck/Push/Native/Types.hs b/services/gundeck/src/Gundeck/Push/Native/Types.hs index d191bfb0459..b58726da4a6 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Types.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Types.hs @@ -29,7 +29,6 @@ module Gundeck.Push.Native.Types addrEndpoint, addrConn, addrClient, - addrEqualClient, addrPushToken, -- * Re-Exports @@ -42,7 +41,7 @@ module Gundeck.Push.Native.Types ) where -import Control.Lens (Lens', makeLenses, view, (^.)) +import Control.Lens (Lens', makeLenses, (^.)) import Data.Id (ClientId, ConnId, UserId) import Gundeck.Aws.Arn import Gundeck.Types @@ -72,11 +71,6 @@ addrToken = addrPushToken . token addrClient :: Lens' Address ClientId addrClient = addrPushToken . tokenClient -addrEqualClient :: Address -> Address -> Bool -addrEqualClient a a' = - view addrConn a == view addrConn a' - || view addrClient a == view addrClient a' - instance Show Address where show a = showString "Address" diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 4780f1142a9..c63daf3cf68 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -39,6 +39,7 @@ import Gundeck.Env qualified as Env import Gundeck.Monad import Gundeck.Options hiding (host, port) import Gundeck.React +import Gundeck.Schema.Run (lastSchemaVersion) import Gundeck.ThreadBudget import Imports hiding (head) import Network.Wai as Wai @@ -59,7 +60,7 @@ run :: Opts -> IO () run o = do (rThreads, e) <- createEnv o runClient (e ^. cstate) $ - versionCheck schemaVersion + versionCheck lastSchemaVersion let l = e ^. applog s <- newSettings $ defaultServer (unpack $ o ^. gundeck . host) (o ^. gundeck . port) l let throttleMillis = fromMaybe defSqsThrottleMillis $ o ^. (settings . sqsThrottleMillis) diff --git a/services/gundeck/src/Gundeck/Util.hs b/services/gundeck/src/Gundeck/Util.hs index 9b210881463..5bc0e77f724 100644 --- a/services/gundeck/src/Gundeck/Util.hs +++ b/services/gundeck/src/Gundeck/Util.hs @@ -47,8 +47,3 @@ mapAsync :: m (t (Either SomeException b)) mapAsync f = mapM waitCatch <=< mapM (async . f) {-# INLINE mapAsync #-} - -maybeEqual :: (Eq a) => Maybe a -> Maybe a -> Bool -maybeEqual (Just x) (Just y) = x == y -maybeEqual _ _ = False -{-# INLINE maybeEqual #-} diff --git a/services/gundeck/src/Gundeck/Util/Redis.hs b/services/gundeck/src/Gundeck/Util/Redis.hs index 891505c39ae..d125d04baca 100644 --- a/services/gundeck/src/Gundeck/Util/Redis.hs +++ b/services/gundeck/src/Gundeck/Util/Redis.hs @@ -29,9 +29,6 @@ import System.Logger.Message retry :: (MonadIO m, MonadMask m, MonadLogger m) => RetryPolicyM m -> m a -> m a retry x = recovering x handlers . const -x1 :: RetryPolicy -x1 = limitRetries 1 <> exponentialBackoff 100000 - x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/proxy/src/Proxy/Options.hs b/services/proxy/src/Proxy/Options.hs index e484dccf6d3..66d8d09c36b 100644 --- a/services/proxy/src/Proxy/Options.hs +++ b/services/proxy/src/Proxy/Options.hs @@ -27,7 +27,6 @@ module Proxy.Options logLevel, logNetStrings, logFormat, - mockOpts, disabledAPIVersions, ) where @@ -36,7 +35,7 @@ import Control.Lens hiding (Level) import Data.Aeson import Data.Aeson.TH import Imports -import System.Logger.Extended (Level (Debug), LogFormat) +import System.Logger.Extended (Level, LogFormat) import Wire.API.Routes.Version data Opts = Opts @@ -64,18 +63,3 @@ data Opts = Opts makeLenses ''Opts deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''Opts - --- | for testing. -mockOpts :: FilePath -> Opts -mockOpts secrets = - Opts - { _host = mempty, - _port = 0, - _secretsConfig = secrets, - _httpPoolSize = 0, - _maxConns = 0, - _logLevel = Debug, - _logNetStrings = pure $ pure $ True, - _logFormat = mempty, - _disabledAPIVersions = mempty - } diff --git a/services/spar/default.nix b/services/spar/default.nix index fe5d88485e7..6256df4df2a 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -199,7 +199,6 @@ mkDerivation { vector wai-extra wai-utilities - warp wire-api xml-conduit yaml diff --git a/services/spar/migrate-data/src/Spar/DataMigration/RIO.hs b/services/spar/migrate-data/src/Spar/DataMigration/RIO.hs deleted file mode 100644 index 3db5aa9aa7c..00000000000 --- a/services/spar/migrate-data/src/Spar/DataMigration/RIO.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module Spar.DataMigration.RIO where - -import Imports - -newtype RIO env a = RIO {unRIO :: ReaderT env IO a} - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader env) - -runRIO :: env -> RIO env a -> IO a -runRIO e f = runReaderT (unRIO f) e - -modifyRef :: (env -> IORef a) -> (a -> a) -> RIO env () -modifyRef get_ mod' = do - ref <- asks get_ - liftIO (modifyIORef ref mod') - -readRef :: (env -> IORef b) -> RIO env b -readRef g = do - ref <- asks g - liftIO $ readIORef ref diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs index 59c30b74b1f..ea329e08f8a 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs @@ -188,10 +188,6 @@ filterResolved resolver migMapInv = yieldOld old go --- for debugging only -resolveNothing :: CollisionResolver -resolveNothing = const (pure . Left) - combineResolver :: CollisionResolver -> CollisionResolver -> CollisionResolver combineResolver resolver1 resolver2 pair olds = resolver1 pair olds >>= \case diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 1e161ee0560..1015d5d2650 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -392,7 +392,6 @@ executable spar-integration , vector , wai-extra , wai-utilities - , warp , wire-api , xml-conduit , yaml @@ -405,7 +404,6 @@ executable spar-migrate-data other-modules: Paths_spar Spar.DataMigration.Options - Spar.DataMigration.RIO Spar.DataMigration.Run Spar.DataMigration.Types Spar.DataMigration.V2_UserV2 diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 12a53e10b96..67d1bd5ace5 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -382,7 +382,7 @@ idpGetAll :: Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do teamid <- Brig.getZUsrCheckPerm zusr ReadIdp - _providers <- IdPConfigStore.getConfigsByTeam teamid + providers <- IdPConfigStore.getConfigsByTeam teamid pure IdPList {..} -- | Delete empty IdPs, or if @"purge=true"@ in the HTTP query, delete all users diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index fc79c7dfb7b..919d1ddce4b 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -23,7 +23,6 @@ module Spar.Data mkTTLAssertions, nominalDiffToSeconds, mkTTLAuthnRequests, - mkTTLAuthnRequestsNDT, -- * SAML Users NormalizedUNameID (..), @@ -75,9 +74,6 @@ mkEnv opts now = mkTTLAuthnRequests :: (MonadError TTLError m) => Env -> UTCTime -> m (TTL "authreq") mkTTLAuthnRequests (Env now maxttl _) = mkTTL now maxttl -mkTTLAuthnRequestsNDT :: (MonadError TTLError m) => Env -> NominalDiffTime -> m (TTL "authreq") -mkTTLAuthnRequestsNDT (Env _ maxttl _) = mkTTLNDT maxttl - mkTTLAssertions :: (MonadError TTLError m) => Env -> UTCTime -> m (TTL "authresp") mkTTLAssertions (Env now _ maxttl) = mkTTL now maxttl diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index acca8893826..9704658039d 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -38,7 +38,6 @@ module Spar.Intra.BrigApp -- * re-exports, mostly for historical reasons and lazyness emailFromSAML, - emailToSAML, emailToSAMLNameID, emailFromSAMLNameID, ) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 90895f2164c..d953b064fa8 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -516,7 +516,7 @@ specCRUDIdentityProvider = do (owner :: UserId, _teamid :: TeamId) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) callIdpGetAll (env ^. teSpar) (Just owner) - `shouldRespondWith` (null . _providers) + `shouldRespondWith` (null . providers) context "some idps are registered" $ do context "client is team owner with email" $ do it "returns a non-empty empty list" $ do @@ -525,7 +525,7 @@ specCRUDIdentityProvider = do (owner, _tid) <- callCreateUserWithTeam _ <- registerTestIdPFrom metadata (env ^. teMgr) owner (env ^. teSpar) callIdpGetAll (env ^. teSpar) (Just owner) - `shouldRespondWith` (not . null . _providers) + `shouldRespondWith` (not . null . providers) context "client is team owner without email" $ do it "returns a non-empty empty list" $ do env <- ask @@ -534,7 +534,7 @@ specCRUDIdentityProvider = do idp <- registerTestIdPFrom metadata (env ^. teMgr) firstOwner (env ^. teSpar) ssoOwner <- mkSsoOwner firstOwner tid idp privcreds callIdpGetAll (env ^. teSpar) (Just ssoOwner) - `shouldRespondWith` (not . null . _providers) + `shouldRespondWith` (not . null . providers) describe "DELETE /identity-providers/:idp" $ do testGetPutDelete (\o t i _ -> callIdpDelete' o t i) context "zuser has wrong team" $ do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 2fa022b1b4f..e0b1233bf5d 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -38,7 +38,6 @@ module Util.Core it, pending, pendingWith, - xit, shouldRespondWith, module Test.Hspec, aFewTimes, @@ -48,8 +47,6 @@ module Util.Core -- * HTTP call, endpointToReq, - endpointToSettings, - endpointToURL, -- * Other randomEmail, @@ -60,7 +57,6 @@ module Util.Core updateProfileBrig, createUserWithTeam, createUserWithTeamDisableSSO, - getSSOEnabledInternal, putSSOEnabledInternal, inviteAndRegisterUser, createTeamMember, @@ -95,7 +91,6 @@ module Util.Core loginSsoUserFirstTime, loginSsoUserFirstTime', loginCreatedSsoUser, - callAuthnReqPrecheck', callAuthnReq, callAuthnReq', callIdpGet, @@ -170,8 +165,6 @@ import qualified Data.Yaml as Yaml import GHC.TypeLits import Imports hiding (head) import Network.HTTP.Client.MultipartFormData -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Options.Applicative as OPA import Polysemy (Sem) import SAML2.WebSSO as SAML hiding ((<$$>)) @@ -299,15 +292,6 @@ it :: SpecWith TestEnv it msg bdy = Test.Hspec.it msg $ runReaderT bdy -xit :: - (HasCallStack) => - -- or, more generally: - -- MonadIO m, Example (TestEnv -> m ()), Arg (TestEnv -> m ()) ~ TestEnv - String -> - TestSpar () -> - SpecWith TestEnv -xit msg bdy = Test.Hspec.xit msg $ runReaderT bdy - pending :: (HasCallStack, MonadIO m) => m () pending = liftIO Test.Hspec.pending @@ -396,12 +380,6 @@ createUserWithTeamDisableSSO brg gly = do pure () pure (uid, tid) -getSSOEnabledInternal :: (HasCallStack, MonadHttp m) => GalleyReq -> TeamId -> m ResponseLBS -getSSOEnabledInternal gly tid = do - get $ - gly - . paths ["i", "teams", toByteString' tid, "features", "sso"] - putSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> FeatureStatus -> m () putSSOEnabledInternal gly tid enabled = do void . put $ @@ -688,21 +666,6 @@ zConn = header "Z-Connection" endpointToReq :: Endpoint -> (Bilge.Request -> Bilge.Request) endpointToReq ep = Bilge.host (ep ^. host . to cs) . Bilge.port (ep ^. port) -endpointToSettings :: Endpoint -> Warp.Settings -endpointToSettings ep = - Warp.defaultSettings - { Warp.settingsHost = Imports.fromString . cs $ ep ^. host, - Warp.settingsPort = fromIntegral $ ep ^. port - } - -endpointToURL :: (MonadIO m) => Endpoint -> Text -> m URI -endpointToURL ep urlpath = either err pure url - where - url = parseURI' ("http://" <> urlhost <> ":" <> urlport) <&> (=/ urlpath) - urlhost = cs $ ep ^. host - urlport = cs . show $ ep ^. port - err = liftIO . throwIO . ErrorCall . show . (,(ep, url)) - -- spar specifics shouldRespondWith :: @@ -793,8 +756,7 @@ getCookie proxy rsp = do then Right $ SimpleSetCookie web else Left $ "bad cookie name. (found, expected) == " <> show (Web.setCookieName web, SAML.cookieName proxy) --- | In 'setResponseCookie' we set an expiration date iff cookie is persistent. So here we test for --- expiration date. Easier than parsing and inspecting the cookie value. +-- | we test for expiration date as it's asier than parsing and inspecting the cookie value. hasPersistentCookieHeader :: ResponseLBS -> Either String () hasPersistentCookieHeader rsp = do cky <- getCookie (Proxy @"zuid") rsp @@ -982,10 +944,6 @@ callAuthnReq' :: (MonadHttp m) => SparReq -> SAML.IdPId -> m ResponseLBS callAuthnReq' sparreq_ idpid = do get $ sparreq_ . path (cs $ "/sso/initiate-login/" -/ SAML.idPIdToST idpid) -callAuthnReqPrecheck' :: (MonadHttp m) => SparReq -> SAML.IdPId -> m ResponseLBS -callAuthnReqPrecheck' sparreq_ idpid = do - head $ sparreq_ . path (cs $ "/sso/initiate-login/" -/ SAML.idPIdToST idpid) - callIdpGet :: (MonadIO m, MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m IdP callIdpGet sparreq_ muid idpid = do resp <- callIdpGet' (sparreq_ . expect2xx) muid idpid diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index 8fe7c002872..49a6ca62690 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -24,13 +24,10 @@ module Util.Email where import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Types.Activation -import Control.Lens (view, (^?)) +import Control.Lens (view) import Control.Monad.Catch (MonadCatch) -import Data.Aeson.Lens import Data.ByteString.Conversion import Data.Id -import qualified Data.Misc as Misc -import Data.Text.Encoding (encodeUtf8) import qualified Data.ZAuth.Token as ZAuth import Imports import Test.Tasty.HUnit @@ -40,44 +37,6 @@ import Util.Types import qualified Wire.API.Team.Feature as Feature import Wire.API.User import Wire.API.User.Activation -import qualified Wire.API.User.Auth as Auth - -changeEmailBrig :: - (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => - BrigReq -> - User -> - Email -> - m ResponseLBS -changeEmailBrig brig usr newEmail = do - -- most of this code is stolen from brig integration tests - let oldEmail = fromJust (userEmail usr) - (cky, tok) <- do - rsp <- - login (emailLogin oldEmail defPassword Nothing) Auth.PersistentCookie - Misc.PlainTextPassword6 -> Maybe Auth.CookieLabel -> Auth.Login - emailLogin e pw cl = - Auth.MkLogin (Auth.LoginByEmail e) pw cl Nothing - - login :: Auth.Login -> Auth.CookieType -> (MonadHttp m) => m ResponseLBS - login l t = - post $ - brig - . path "/login" - . (if t == Auth.PersistentCookie then queryItem "persist" "true" else id) - . json l - - decodeCookie :: (HasCallStack) => Response a -> Bilge.Cookie - decodeCookie = fromMaybe (error "missing zuid cookie") . Bilge.getCookie "zuid" - - decodeToken :: (HasCallStack) => Response (Maybe LByteString) -> ZAuth.Token ZAuth.Access - decodeToken r = fromMaybe (error "invalid access_token") $ do - x <- responseBody r - t <- x ^? key "access_token" . _String - fromByteString (encodeUtf8 t) changeEmailBrigCreds :: (MonadHttp m, HasCallStack) => diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 40ef9884d0a..0dac2a24a75 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -603,9 +603,6 @@ acceptScim = accept "application/scim+json" scimUserId :: Scim.StoredUser SparTag -> UserId scimUserId = Scim.id . Scim.thing -scimPreferredLanguage :: Scim.StoredUser SparTag -> Maybe Text -scimPreferredLanguage = Scim.preferredLanguage . Scim.value . Scim.thing - -- | There are a number of user types that all partially map on each other. This class -- provides a uniform interface to data stored in those types. -- diff --git a/tools/db/inconsistencies/src/Options.hs b/tools/db/inconsistencies/src/Options.hs index 95f7e27e95f..ad81539b070 100644 --- a/tools/db/inconsistencies/src/Options.hs +++ b/tools/db/inconsistencies/src/Options.hs @@ -20,7 +20,6 @@ module Options where import Cassandra qualified as C -import Data.Id import Data.Text qualified as Text import Imports import Options.Applicative @@ -97,15 +96,6 @@ inconsistenciesFileParser = <> metavar "FILEPATH" ) -teamIdParser :: Parser TeamId -teamIdParser = - option - (eitherReader (parseIdFromText . Text.pack)) - ( long "team-id" - <> help "Team id to search into" - <> metavar "TEAM_ID" - ) - cassandraSettingsParser :: String -> Parser CassandraSettings cassandraSettingsParser ks = CassandraSettings diff --git a/tools/db/move-team/src/Schema.hs b/tools/db/move-team/src/Schema.hs index 2249bb2f1a5..00c08360bf6 100644 --- a/tools/db/move-team/src/Schema.hs +++ b/tools/db/move-team/src/Schema.hs @@ -22,7 +22,6 @@ module Schema where import Cassandra import Common import Data.Conduit -import Data.Handle (Handle) import Data.IP (IP) import Data.Id import Data.Time @@ -32,7 +31,6 @@ import Imports import System.FilePath.Posix (()) import Types import Wire.API.Team.Permission -import Wire.API.User.Password (PasswordResetKey) -- This file was autogenerated by move-team-generate @@ -178,14 +176,6 @@ importBrigLoginCodes Env {..} path = do type RowBrigPasswordReset = (Maybe Ascii, Maybe Ascii, Maybe Int32, Maybe UTCTime, Maybe UUID) -selectBrigPasswordReset :: PrepQuery R (Identity [PasswordResetKey]) RowBrigPasswordReset -selectBrigPasswordReset = "SELECT key, code, retries, timeout, user FROM password_reset WHERE key in ?" - -readBrigPasswordReset :: Env -> [PasswordResetKey] -> ConduitM () [RowBrigPasswordReset] IO () -readBrigPasswordReset Env {..} reset_keys = - transPipe (runClient envBrig) $ - paginateC selectBrigPasswordReset (paramsP LocalQuorum (pure reset_keys) envPageSize) x5 - selectBrigPasswordResetAll :: PrepQuery R () RowBrigPasswordReset selectBrigPasswordResetAll = "SELECT key, code, retries, timeout, user FROM password_reset" @@ -408,14 +398,6 @@ importBrigUser Env {..} path = do type RowBrigUserHandle = (Maybe Text, Maybe UUID) -selectBrigUserHandle :: PrepQuery R (Identity [Handle]) RowBrigUserHandle -selectBrigUserHandle = "SELECT handle, user FROM user_handle WHERE handle in ?" - -readBrigUserHandle :: Env -> [Handle] -> ConduitM () [RowBrigUserHandle] IO () -readBrigUserHandle Env {..} handles = - transPipe (runClient envBrig) $ - paginateC selectBrigUserHandle (paramsP LocalQuorum (pure handles) envPageSize) x5 - selectBrigUserHandleAll :: PrepQuery R () RowBrigUserHandle selectBrigUserHandleAll = "SELECT handle, user FROM user_handle" @@ -454,14 +436,6 @@ importBrigUserHandle Env {..} path = do type RowBrigUserKeys = (Maybe Text, Maybe UUID) -selectBrigUserKeys :: PrepQuery R (Identity [Int32]) RowBrigUserKeys -selectBrigUserKeys = "SELECT key, user FROM user_keys WHERE key in ?" - -readBrigUserKeys :: Env -> [Int32] -> ConduitM () [RowBrigUserKeys] IO () -readBrigUserKeys Env {..} keys = - transPipe (runClient envBrig) $ - paginateC selectBrigUserKeys (paramsP LocalQuorum (pure keys) envPageSize) x5 - selectBrigUserKeysAll :: PrepQuery R () RowBrigUserKeys selectBrigUserKeysAll = "SELECT key, user FROM user_keys" @@ -1144,14 +1118,6 @@ importSparScimUserTimes Env {..} path = do type RowSparUser = (Maybe Text, Maybe Text, Maybe UUID) -selectSparUser :: PrepQuery R (Identity [Text]) RowSparUser -selectSparUser = "SELECT issuer, sso_id, uid FROM user WHERE issuer in ?" - -readSparUser :: Env -> [Text] -> ConduitM () [RowSparUser] IO () -readSparUser Env {..} issuer = - transPipe (runClient envSpar) $ - paginateC selectSparUser (paramsP LocalQuorum (pure issuer) envPageSize) x5 - selectSparUserAll :: PrepQuery R () RowSparUser selectSparUserAll = "SELECT issuer, sso_id, uid FROM user" diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 8ccf0f63f20..cde1f4ba46a 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -87,7 +87,6 @@ mkDerivation { types-common unliftio utf8-string - uuid wai wai-utilities wire-api diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 3a75f308748..3c044890795 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -26,7 +26,7 @@ module Stern.App where import Bilge qualified import Bilge.RPC (HasRequestId (..)) import Control.Error -import Control.Lens (makeLenses, set, view, (^.)) +import Control.Lens (makeLenses, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.IO.Class import Control.Monad.Reader.Class @@ -34,16 +34,10 @@ import Control.Monad.Trans.Class import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Text.Encoding (encodeUtf8) -import Data.UUID (toString) -import Data.UUID.V4 qualified as UUID import Imports import Network.HTTP.Client (responseTimeoutMicro) -import Network.Wai (Request, Response, ResponseReceived) -import Network.Wai.Utilities (Error (..), lookupRequestId) -import Network.Wai.Utilities.Error qualified as WaiError -import Network.Wai.Utilities.Response (json, setStatus) -import Network.Wai.Utilities.Server (defaultRequestIdHeaderName) -import Network.Wai.Utilities.Server qualified as Server +import Network.Wai (Response, ResponseReceived) +import Network.Wai.Utilities (Error (..)) import Stern.Options as O import System.Logger qualified as Log import System.Logger.Class hiding (Error, info) @@ -124,23 +118,5 @@ type Handler = ExceptT Error App type Continue m = Response -> m ResponseReceived -runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived -runHandler e r h k = do - i <- reqId (lookupRequestId defaultRequestIdHeaderName r) - let e' = set requestId (Bilge.RequestId i) e - a <- runAppT e' (runExceptT h) - either (onError (view applog e) r k) pure a - where - reqId (Just i) = pure i - reqId Nothing = do - uuid <- UUID.nextRandom - pure $ toByteString' $ "stern-" ++ toString uuid - -onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived -onError g r k e = do - Server.logError g (Just r) e - Server.flushRequestBody r - k (setStatus (WaiError.code e) (json e)) - userMsg :: UserId -> Msg -> Msg userMsg = field "user" . toByteString' diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 59636d7e5ba..326f5ebf821 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -23,7 +23,6 @@ module Stern.Intra ( backendApiVersion, - putUser, putUserStatus, getContacts, getUserConnections, @@ -141,24 +140,6 @@ versionedPaths = Bilge.paths . (encodeUtf8 (toUrlPiece backendApiVersion) :) ------------------------------------------------------------------------------- -putUser :: UserId -> UserUpdate -> Handler () -putUser uid upd = do - info $ userMsg uid . msg "Changing user state" - b <- view brig - void $ - catchRpcErrors $ - rpc' - "brig" - b - ( method PUT - . versionedPath "self" - . header "Z-User" (toByteString' uid) - . header "Z-Connection" (toByteString' "") - . lbytes (encode upd) - . contentJson - . expect2xx - ) - putUserStatus :: AccountStatus -> UserId -> Handler () putUserStatus status uid = do info $ userMsg uid . msg "Changing user status" diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index e7572f7c330..01b6639617a 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -101,7 +101,6 @@ library , types-common >=0.4.13 , unliftio , utf8-string - , uuid >=1.3 , wai >=3.0 , wai-utilities >=0.9 , wire-api >=0.1 diff --git a/weeder.toml b/weeder.toml index e0ddc4c24e5..3b2d1056098 100644 --- a/weeder.toml +++ b/weeder.toml @@ -10,16 +10,18 @@ roots = [ # may of the entries here are about general-purpose module "^API.Galley.consentToLegalHold", # FUTUREWORK: write tests that need this! "^API.Galley.enableLegalHold", # FUTUREWORK: write tests that need this! "^API.Galley.getLegalHoldStatus", # FUTUREWORK: write tests that need this! - "^Data.ETag.opaqueDigest", + "^API.MLS.Util.getKeyPackageCount", + "^API.MLS.Util.getKeyPair", + "^API.MLS.Util.getCurrentGroupId", "^Data.ETag._OpaqueDigest", + "^Data.ETag._StrictETag", + "^Data.ETag._WeakETag", + "^Data.ETag.opaqueDigest", "^Data.ETag.opaqueMD5", "^Data.ETag.opaqueSHA1", "^Data.ETag.strictETag", - "^Data.ETag._StrictETag", "^Data.ETag.weakETag", - "^Data.ETag._WeakETag", "^Data.Qualified.isLocal", - "^Data.Range.(<|)", "^Data.Range.rappend", "^Data.Range.rcons", "^Data.Range.rinc", @@ -32,16 +34,31 @@ roots = [ # may of the entries here are about general-purpose module "^Imports.readLn", "^Main.main$", "^Paths_.*", + "^Spec.main$", "^Test.Cargohold.API.Util.shouldMatchALittle", "^Test.Cargohold.API.Util.shouldMatchLeniently", "^Test.Cargohold.API.Util.shouldMatchSloppily", - "^Testlib.JSON.(<$$$>)", + "^Test.Data.Schema.detailSchema", + "^Test.Data.Schema.userSchemaWithDefaultName", + "^Test.Data.Schema.userSchemaWithDefaultName'", + "^TestSetup.runFederationClient", + "^TestSetup.viewCargohold", + "^Testlib.Cannon.awaitAtLeastNMatches", + "^Testlib.Cannon.awaitAtLeastNMatchesResult", + "^Testlib.Cannon.awaitNToMMatches", + "^Testlib.Cannon.awaitNToMMatchesResult", + "^Testlib.Cannon.prettyAwaitAtLeastResult", + "^Testlib.Cannon.printAwaitAtLeastResult", + "^Testlib.Cannon.printAwaitResult", "^Testlib.JSON.member", "^Testlib.Prelude.appendFile", "^Testlib.Prelude.getChar", "^Testlib.Prelude.getContents", "^Testlib.Prelude.getLine", "^Testlib.Prelude.interact", + "^Testlib.Prelude.print", + "^Testlib.Prelude.putChar", + "^Testlib.Prelude.putStr", "^Testlib.Prelude.readFile", "^Testlib.Prelude.readIO", "^Testlib.Prelude.readLn", @@ -50,6 +67,31 @@ roots = [ # may of the entries here are about general-purpose module "^Testlib.Printing.hline", "^Testlib.Run.main$", "^Testlib.RunServices.main$", + "^ThreadBudget.extractLogHistory", + "^Util.assertOne", + "^Util.randomActivationCode", + "^Util.zClient", + "^Web.Scim.Client.deleteGroup", + "^Web.Scim.Client.deleteUser", + "^Web.Scim.Client.getGroup", + "^Web.Scim.Client.getGroups", + "^Web.Scim.Client.getSchemas", + "^Web.Scim.Client.getUser", + "^Web.Scim.Client.getUsers", + "^Web.Scim.Client.patchGroup", + "^Web.Scim.Client.patchUser", + "^Web.Scim.Client.postGroup", + "^Web.Scim.Client.postUser", + "^Web.Scim.Client.putGroup", + "^Web.Scim.Client.resourceTypes", + "^Web.Scim.Client.schema", + "^Web.Scim.Client.scimClients", + "^Web.Scim.Client.scimClients", + "^Web.Scim.Client.spConfig", + "^Web.Scim.Test.Util.getField", + "^Web.Scim.Test.Util.put'", + "^Web.Scim.Test.Util.scim", + "^Web.Scim.Test.Util.shouldEventuallyRespondWith", "^Test.Wire.API.Golden.Run.main$" ] type-class-roots = true # `root-instances` is more precise, but requires more config maintenance.