From c950a3a7a0a15ed3ea87e1ac57232884145c5c46 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 29 Apr 2024 10:52:13 +0200 Subject: [PATCH 01/30] Refactor ciphersuite handling for 1-1 convs (#4009) * Introduce ActiveMLSConversationData This changes the conversation and subconversation metadata so that epoch, epoch timestamp and ciphersuites are all simultaneously optional. This makes it possible not to set a ciphersuite for conversations until they receive a commit. * Fix assertions in integration tests * Add more versioned conversation endpoints * Make SubConversation record versioned * Adapt galley to versioning changes * Adapt and expand conversation golden tests * Fix arbitrary instance of ConversationMLSData * Test old versions of conversation metadata * Restore epoch field in Conversation serialisation * Add CHANGELOG entry * Lint * Test MLS 1-1 with other ciphersuites * Fix assertion in galley integration test * fixup! Fix assertion in galley integration test --- changelog.d/1-api-changes/mls-ciphersuite | 1 + integration/test/MLS/Util.hs | 4 +- integration/test/Test/MLS.hs | 21 ++- integration/test/Test/MLS/One2One.hs | 19 +- integration/test/Test/Version.hs | 13 ++ integration/test/Testlib/JSON.hs | 7 + .../Federation/Golden/ConversationCreated.hs | 13 +- libs/wire-api/src/Wire/API/Conversation.hs | 89 ++++----- .../src/Wire/API/Conversation/Protocol.hs | 145 ++++++++++++--- .../src/Wire/API/Event/Conversation.hs | 4 +- .../src/Wire/API/MLS/SubConversation.hs | 46 +++-- .../src/Wire/API/Routes/Internal/Galley.hs | 3 +- .../API/Routes/Public/Galley/Conversation.hs | 170 +++++++++++++----- libs/wire-api/src/Wire/API/Routes/Version.hs | 1 + .../golden/Test/Wire/API/Golden/Generated.hs | 18 +- .../API/Golden/Generated/Conversation_user.hs | 161 ++++++++++++++++- .../golden/Test/Wire/API/Golden/Manual.hs | 11 ++ .../Golden/Manual/ConversationsResponse.hs | 102 +---------- .../Wire/API/Golden/Manual/SubConversation.hs | 14 +- .../testObject_Conversation_user_3.json | 60 +++++++ .../testObject_Conversation_user_4.json | 58 ++++++ .../testObject_Conversation_user_5.json | 39 ++++ .../testObject_Conversation_v2_user_3.json | 61 +++++++ .../testObject_Conversation_v2_user_4.json | 60 +++++++ .../testObject_Conversation_v2_user_5.json | 40 +++++ .../testObject_Conversation_v5_user_1.json | 39 ++++ .../testObject_Conversation_v5_user_2.json | 70 ++++++++ .../testObject_Conversation_v5_user_3.json | 60 +++++++ .../testObject_Conversation_v5_user_4.json | 59 ++++++ .../testObject_Conversation_v5_user_5.json | 39 ++++ ...testObject_ConversationsResponse_v5_1.json | 123 +++++++++++++ .../testObject_PublicSubConversation_2.json | 2 - ...testObject_PublicSubConversation_v5_1.json | 12 ++ ...testObject_PublicSubConversation_v5_2.json | 17 ++ services/galley/src/Galley/API/Create.hs | 21 +-- .../galley/src/Galley/API/MLS/Commit/Core.hs | 14 +- .../Galley/API/MLS/Commit/ExternalCommit.hs | 14 +- .../Galley/API/MLS/Commit/InternalCommit.hs | 8 +- services/galley/src/Galley/API/MLS/Message.hs | 54 +++--- services/galley/src/Galley/API/MLS/One2One.hs | 5 +- .../galley/src/Galley/API/MLS/Proposal.hs | 57 +++--- services/galley/src/Galley/API/MLS/Removal.hs | 8 +- .../src/Galley/API/MLS/SubConversation.hs | 10 +- services/galley/src/Galley/API/MLS/Types.hs | 35 ++-- .../src/Galley/API/Public/Conversation.hs | 6 + services/galley/src/Galley/API/Util.hs | 2 +- .../src/Galley/Cassandra/Conversation.hs | 50 ++---- .../galley/src/Galley/Cassandra/Queries.hs | 15 +- .../src/Galley/Cassandra/SubConversation.hs | 45 +++-- .../Galley/Effects/SubConversationStore.hs | 2 +- services/galley/test/integration/API/MLS.hs | 16 +- 51 files changed, 1484 insertions(+), 459 deletions(-) create mode 100644 changelog.d/1-api-changes/mls-ciphersuite create mode 100644 libs/wire-api/test/golden/testObject_Conversation_user_3.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_user_4.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_user_5.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v2_user_3.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v2_user_4.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v2_user_5.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v5_user_1.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v5_user_2.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v5_user_3.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v5_user_4.json create mode 100644 libs/wire-api/test/golden/testObject_Conversation_v5_user_5.json create mode 100644 libs/wire-api/test/golden/testObject_ConversationsResponse_v5_1.json create mode 100644 libs/wire-api/test/golden/testObject_PublicSubConversation_v5_1.json create mode 100644 libs/wire-api/test/golden/testObject_PublicSubConversation_v5_2.json diff --git a/changelog.d/1-api-changes/mls-ciphersuite b/changelog.d/1-api-changes/mls-ciphersuite new file mode 100644 index 00000000000..4d24c2f0060 --- /dev/null +++ b/changelog.d/1-api-changes/mls-ciphersuite @@ -0,0 +1 @@ +The `cipher_suite` field is not present anymore in objects corresponding to newly created conversations diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index eeb69bae965..2a59f980579 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -202,11 +202,9 @@ createNewGroup cid = do createSelfGroup :: (HasCallStack) => ClientIdentity -> App (String, Value) createSelfGroup cid = do conv <- getSelfConversation cid >>= getJSON 200 - conv %. "epoch" `shouldMatchInt` 0 groupId <- conv %. "group_id" & asString - convId <- conv %. "qualified_id" createGroup cid conv - pure (groupId, convId) + pure (groupId, conv) createGroup :: (MakesValue conv) => ClientIdentity -> conv -> App () createGroup cid conv = do diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index db831848077..aba592e4ecf 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -12,6 +12,7 @@ import qualified Data.Text.Encoding as T import MLS.Util import Notifications import SetupHelpers +import Test.Version import Testlib.Prelude testSendMessageNoReturnToSender :: HasCallStack => App () @@ -331,7 +332,14 @@ testAddUserSimple suite ctype = do [alice1, bob2] <- traverse (createMLSClient def {credType = ctype}) [alice, bob] traverse_ uploadNewKeyPackage [bob2] - (_, qcnv) <- createNewGroup alice1 + qcnv <- withWebSocket alice $ \ws -> do + (_, qcnv) <- createNewGroup alice1 + -- check that the conversation inside the ConvCreated event contains + -- epoch and ciphersuite, regardless of the API version + n <- awaitMatch isConvCreateNotif ws + n %. "payload.0.data.epoch" `shouldMatchInt` 0 + n %. "payload.0.data.cipher_suite" `shouldMatchInt` 1 + pure qcnv resp <- createAddCommit alice1 [bob] >>= sendAndConsumeCommitBundle events <- resp %. "events" & asList @@ -412,12 +420,17 @@ testCreateSubConvProteus = do bindResponse (getSubConversation alice conv "conference") $ \resp -> resp.status `shouldMatchInt` 404 -testSelfConversation :: App () -testSelfConversation = do +testSelfConversation :: Version5 -> App () +testSelfConversation v = withVersion5 v $ do alice <- randomUser OwnDomain def creator : others <- traverse (createMLSClient def) (replicate 3 alice) traverse_ uploadNewKeyPackage others - void $ createSelfGroup creator + (_, conv) <- createSelfGroup creator + conv %. "epoch" `shouldMatchInt` 0 + case v of + Version5 -> conv %. "cipher_suite" `shouldMatchInt` 1 + NoVersion5 -> assertFieldMissing conv "cipher_suite" + void $ createAddCommit creator [alice] >>= sendAndConsumeCommitBundle newClient <- createMLSClient def alice diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index 8c6ce11355d..2598c10ad5b 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -25,18 +25,26 @@ import qualified Data.Set as Set import MLS.Util import Notifications import SetupHelpers +import Test.Version import Testlib.Prelude -testGetMLSOne2One :: HasCallStack => Domain -> App () -testGetMLSOne2One otherDomain = do +testGetMLSOne2One :: HasCallStack => Version5 -> Domain -> App () +testGetMLSOne2One v otherDomain = withVersion5 v $ do [alice, bob] <- createAndConnectUsers [OwnDomain, otherDomain] + let assertConvData conv = do + conv %. "epoch" `shouldMatchInt` 0 + case v of + Version5 -> conv %. "cipher_suite" `shouldMatchInt` 1 + NoVersion5 -> assertFieldMissing conv "cipher_suite" + conv <- getMLSOne2OneConversation alice bob >>= getJSON 200 conv %. "type" `shouldMatchInt` 2 shouldBeEmpty (conv %. "members.others") conv %. "members.self.conversation_role" `shouldMatch` "wire_member" conv %. "members.self.qualified_id" `shouldMatch` (alice %. "qualified_id") + assertConvData conv convId <- conv %. "qualified_id" @@ -47,7 +55,7 @@ testGetMLSOne2One otherDomain = do conv2 %. "type" `shouldMatchInt` 2 conv2 %. "qualified_id" `shouldMatch` convId - conv2 %. "epoch" `shouldMatch` (conv %. "epoch") + assertConvData conv2 testMLSOne2OneOtherMember :: HasCallStack => One2OneScenario -> App () testMLSOne2OneOtherMember scenario = do @@ -220,8 +228,9 @@ one2OneScenarioConvDomain One2OneScenarioLocal = OwnDomain one2OneScenarioConvDomain One2OneScenarioLocalConv = OwnDomain one2OneScenarioConvDomain One2OneScenarioRemoteConv = OtherDomain -testMLSOne2One :: HasCallStack => One2OneScenario -> App () -testMLSOne2One scenario = do +testMLSOne2One :: HasCallStack => Ciphersuite -> One2OneScenario -> App () +testMLSOne2One suite scenario = do + setMLSCiphersuite suite alice <- randomUser OwnDomain def let otherDomain = one2OneScenarioUserDomain scenario convDomain = one2OneScenarioConvDomain scenario diff --git a/integration/test/Test/Version.hs b/integration/test/Test/Version.hs index 31295918468..40c4dfeb14d 100644 --- a/integration/test/Test/Version.hs +++ b/integration/test/Test/Version.hs @@ -17,6 +17,19 @@ instance TestCases Versioned' where MkTestCase "[version=v6]" (Versioned' (ExplicitVersion 6)) ] +-- | Used to test endpoints that have changed after version 5 +data Version5 = Version5 | NoVersion5 + +instance TestCases Version5 where + testCases = + [ MkTestCase "[version=versioned]" NoVersion5, + MkTestCase "[version=v5]" Version5 + ] + +withVersion5 :: Version5 -> App a -> App a +withVersion5 Version5 = withAPIVersion 5 +withVersion5 NoVersion5 = id + testVersion :: Versioned' -> App () testVersion (Versioned' v) = withModifiedBackend def {brigCfg = setField "optSettings.setDisabledAPIVersions" ([] :: [String])} diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index 5faa2b97f05..62eda62cba2 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -178,6 +178,13 @@ fieldEquals a fieldSelector b = do Just f -> f `isEqual` b +assertFieldMissing :: (HasCallStack, MakesValue a) => a -> String -> App () +assertFieldMissing x k = do + mValue <- lookupField x k + case mValue of + Nothing -> pure () + Just _ -> assertFailureWithJSON x $ "Field \"" <> k <> "\" should be missing from object:" + assertField :: (HasCallStack, MakesValue a) => a -> String -> Maybe Value -> App Value assertField x k Nothing = assertFailureWithJSON x $ "Field \"" <> k <> "\" is missing from object:" assertField _ _ (Just x) = pure x diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs index 432ea013b98..61a98694401 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs @@ -86,5 +86,16 @@ testObject_ConversationCreated2 = nonCreatorMembers = Set.fromList [], messageTimer = Nothing, receiptMode = Nothing, - protocol = ProtocolMLS (ConversationMLSData (GroupId "group") (Epoch 3) (Just (UTCTime (fromGregorian 2020 8 29) 0)) MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519) + protocol = + ProtocolMLS + ( ConversationMLSData + (GroupId "group") + ( Just + ( ActiveMLSConversationData + (Epoch 3) + (UTCTime (fromGregorian 2020 8 29) 0) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ) + ) + ) } diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 120ffe6a921..1165445df2f 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -104,11 +104,11 @@ import Data.Range (Range, fromRange, rangedSchema) import Data.SOP import Data.Schema import Data.Set qualified as Set +import Data.Singletons import Data.Text qualified as Text import Data.UUID qualified as UUID import Data.UUID.V5 qualified as UUIDV5 import Imports -import Servant.API import System.Random (randomRIO) import Wire.API.Conversation.Member import Wire.API.Conversation.Protocol @@ -155,9 +155,9 @@ defConversationMetadata mCreator = cnvmReceiptMode = Nothing } -accessRolesVersionedSchema :: Version -> ObjectSchema SwaggerDoc (Set AccessRole) -accessRolesVersionedSchema v = - if v > V2 then accessRolesSchema else accessRolesSchemaV2 +accessRolesVersionedSchema :: Maybe Version -> ObjectSchema SwaggerDoc (Set AccessRole) +accessRolesVersionedSchema (Just v) | v < V3 = accessRolesSchemaV2 +accessRolesVersionedSchema _ = accessRolesSchema accessRolesSchema :: ObjectSchema SwaggerDoc (Set AccessRole) accessRolesSchema = field "access_role" (set schema) @@ -266,12 +266,12 @@ cnvReceiptMode :: Conversation -> Maybe ReceiptMode cnvReceiptMode = cnvmReceiptMode . cnvMetadata instance ToSchema Conversation where - schema = conversationSchema V3 + schema = conversationSchema Nothing -instance ToSchema (Versioned 'V2 Conversation) where - schema = Versioned <$> unVersioned .= conversationSchema V2 +instance SingI v => ToSchema (Versioned v Conversation) where + schema = Versioned <$> unVersioned .= conversationSchema (Just (demote @v)) -conversationObjectSchema :: Version -> ObjectSchema SwaggerDoc Conversation +conversationObjectSchema :: Maybe Version -> ObjectSchema SwaggerDoc Conversation conversationObjectSchema v = Conversation <$> cnvQualifiedId .= field "qualified_id" schema @@ -279,14 +279,14 @@ conversationObjectSchema v = .= optional (field "id" (deprecatedSchema "qualified_id" schema)) <*> cnvMetadata .= conversationMetadataObjectSchema (accessRolesVersionedSchema v) <*> cnvMembers .= field "members" schema - <*> cnvProtocol .= protocolSchema + <*> cnvProtocol .= protocolSchema v conversationSchema :: - Version -> + Maybe Version -> ValueSchema NamedSwaggerDoc Conversation conversationSchema v = objectWithDocModifier - "Conversation" + ("Conversation" <> foldMap (Text.toUpper . versionText) v) (description ?~ "A conversation object as returned from the server") (conversationObjectSchema v) @@ -303,20 +303,26 @@ data CreateGroupConversation = CreateGroupConversation deriving (ToJSON, FromJSON, S.ToSchema) via Schema CreateGroupConversation instance ToSchema CreateGroupConversation where - schema = - objectWithDocModifier - "CreateGroupConversation" - (description ?~ "A created group-conversation object extended with a list of failed-to-add users") - $ CreateGroupConversation - <$> cgcConversation .= conversationObjectSchema V4 - <*> (toFlatList . cgcFailedToAdd) - .= field "failed_to_add" (fromFlatList <$> array schema) - where - toFlatList :: Map Domain (Set a) -> [Qualified a] - toFlatList m = - (\(d, s) -> flip Qualified d <$> Set.toList s) =<< Map.assocs m - fromFlatList :: Ord a => [Qualified a] -> Map Domain (Set a) - fromFlatList = fmap Set.fromList . indexQualified + schema = createGroupConversationSchema Nothing + +instance SingI v => ToSchema (Versioned v CreateGroupConversation) where + schema = Versioned <$> unVersioned .= createGroupConversationSchema (Just (demote @v)) + +createGroupConversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc CreateGroupConversation +createGroupConversationSchema v = + objectWithDocModifier + "CreateGroupConversation" + (description ?~ "A created group-conversation object extended with a list of failed-to-add users") + $ CreateGroupConversation + <$> cgcConversation .= conversationObjectSchema v + <*> (toFlatList . cgcFailedToAdd) + .= field "failed_to_add" (fromFlatList <$> array schema) + where + toFlatList :: Map Domain (Set a) -> [Qualified a] + toFlatList m = + (\(d, s) -> flip Qualified d <$> Set.toList s) =<< Map.assocs m + fromFlatList :: Ord a => [Qualified a] -> Map Domain (Set a) + fromFlatList = fmap Set.fromList . indexQualified -- | Limited view of a 'Conversation'. Is used to inform users with an invite -- link about the conversation. @@ -365,7 +371,7 @@ instance ToSchema (Versioned 'V2 (ConversationList Conversation)) where schema = Versioned <$> unVersioned - .= conversationListSchema (conversationSchema V2) + .= conversationListSchema (conversationSchema (Just V2)) conversationListSchema :: forall a. @@ -427,13 +433,13 @@ data ConversationsResponse = ConversationsResponse deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationsResponse conversationsResponseSchema :: - Version -> + Maybe Version -> ValueSchema NamedSwaggerDoc ConversationsResponse conversationsResponseSchema v = let notFoundDoc = description ?~ "These conversations either don't exist or are deleted." failedDoc = description ?~ "The server failed to fetch these conversations, most likely due to network issues while contacting a remote server" in objectWithDocModifier - "ConversationsResponse" + ("ConversationsResponse" <> foldMap (Text.toUpper . versionText) v) (description ?~ "Response object for getting metadata of a list of conversations") $ ConversationsResponse <$> crFound .= field "found" (array (conversationSchema v)) @@ -441,10 +447,10 @@ conversationsResponseSchema v = <*> crFailed .= fieldWithDocModifier "failed" failedDoc (array schema) instance ToSchema ConversationsResponse where - schema = conversationsResponseSchema V3 + schema = conversationsResponseSchema Nothing -instance ToSchema (Versioned 'V2 ConversationsResponse) where - schema = Versioned <$> unVersioned .= conversationsResponseSchema V2 +instance SingI v => ToSchema (Versioned v ConversationsResponse) where + schema = Versioned <$> unVersioned .= conversationsResponseSchema (Just (demote @v)) -------------------------------------------------------------------------------- -- Conversation properties @@ -659,18 +665,19 @@ data NewConv = NewConv instance ToSchema NewConv where schema = - newConvSchema $ + newConvSchema Nothing $ maybe_ (optField "access_role" (set schema)) instance ToSchema (Versioned 'V2 NewConv) where - schema = Versioned <$> unVersioned .= newConvSchema accessRolesSchemaOptV2 + schema = Versioned <$> unVersioned .= newConvSchema (Just V2) accessRolesSchemaOptV2 newConvSchema :: + Maybe Version -> ObjectSchema SwaggerDoc (Maybe (Set AccessRole)) -> ValueSchema NamedSwaggerDoc NewConv -newConvSchema sch = +newConvSchema v sch = objectWithDocModifier - "NewConv" + ("NewConv" <> foldMap (Text.toUpper . versionText) v) (description ?~ "JSON object to create a new conversation. When using 'qualified_users' (preferred), you can omit 'users'") $ NewConv <$> newConvUsers @@ -831,22 +838,18 @@ data ConversationAccessData = ConversationAccessData deriving (Arbitrary) via (GenericUniform ConversationAccessData) deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationAccessData -conversationAccessDataSchema :: Version -> ValueSchema NamedSwaggerDoc ConversationAccessData +conversationAccessDataSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc ConversationAccessData conversationAccessDataSchema v = - object ("ConversationAccessData" <> suffix) $ + object ("ConversationAccessData" <> foldMap (Text.toUpper . versionText) v) $ ConversationAccessData <$> cupAccess .= field "access" (set schema) <*> cupAccessRoles .= accessRolesVersionedSchema v - where - suffix - | v == maxBound = "" - | otherwise = toUrlPiece v instance ToSchema ConversationAccessData where - schema = conversationAccessDataSchema V3 + schema = conversationAccessDataSchema Nothing instance ToSchema (Versioned 'V2 ConversationAccessData) where - schema = Versioned <$> unVersioned .= conversationAccessDataSchema V2 + schema = Versioned <$> unVersioned .= conversationAccessDataSchema (Just V2) data ConversationReceiptModeUpdate = ConversationReceiptModeUpdate { cruReceiptMode :: ReceiptMode diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index 321c106b6de..c0060347b7b 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -31,22 +31,29 @@ module Wire.API.Conversation.Protocol conversationMLSData, protocolSchema, ConversationMLSData (..), + ActiveMLSConversationData (..), + optionalActiveMLSConversationDataSchema, + cnvmlsEpoch, ProtocolUpdate (..), ) where +import Control.Applicative import Control.Arrow import Control.Lens (Traversal', makePrisms, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Json.Util import Data.OpenApi qualified as S import Data.Schema import Data.Time.Clock import Imports +import Test.QuickCheck import Wire.API.Conversation.Action.Tag import Wire.API.MLS.CipherSuite import Wire.API.MLS.Epoch import Wire.API.MLS.Group -import Wire.API.MLS.SubConversation +import Wire.API.Routes.Version +import Wire.API.Routes.Versioned import Wire.Arbitrary data ProtocolTag = ProtocolProteusTag | ProtocolMLSTag | ProtocolMixedTag @@ -58,44 +65,132 @@ instance S.ToSchema ProtocolTag data ConversationMLSData = ConversationMLSData { -- | The MLS group ID associated to the conversation. cnvmlsGroupId :: GroupId, - -- | The current epoch number of the corresponding MLS group. - cnvmlsEpoch :: Epoch, - -- | The time stamp of the epoch. - cnvmlsEpochTimestamp :: Maybe UTCTime, - -- | The cipher suite to be used in the MLS group. - cnvmlsCipherSuite :: CipherSuiteTag + -- | Information available once the conversation is active (epoch > 0). + cnvmlsActiveData :: Maybe ActiveMLSConversationData } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via GenericUniform ConversationMLSData deriving (ToJSON, FromJSON) via Schema ConversationMLSData -mlsDataSchema :: ObjectSchema SwaggerDoc ConversationMLSData -mlsDataSchema = +arbitraryActiveData :: Gen (Maybe ActiveMLSConversationData) +arbitraryActiveData = do + epoch <- arbitrary + if epoch == Epoch 0 + then pure Nothing + else + fmap Just $ + ActiveMLSConversationData epoch <$> arbitrary <*> arbitrary + +instance Arbitrary ConversationMLSData where + arbitrary = ConversationMLSData <$> arbitrary <*> arbitraryActiveData + +cnvmlsEpoch :: ConversationMLSData -> Epoch +cnvmlsEpoch = maybe (Epoch 0) (.epoch) . cnvmlsActiveData + +mlsDataSchema :: Maybe Version -> ObjectSchema SwaggerDoc ConversationMLSData +mlsDataSchema v = ConversationMLSData <$> cnvmlsGroupId .= fieldWithDocModifier "group_id" (description ?~ "A base64-encoded MLS group ID") schema - <*> cnvmlsEpoch + <*> cnvmlsActiveData .= optionalActiveMLSConversationDataSchema v + +optionalActiveMLSConversationDataSchema :: + Maybe Version -> + ObjectSchema SwaggerDoc (Maybe ActiveMLSConversationData) +optionalActiveMLSConversationDataSchema (Just v) + | v < V6 = + -- legacy serialisation + mk + <$> maybe (Epoch 0) (.epoch) + .= fieldWithDocModifier + "epoch" + (description ?~ "The epoch number of the corresponding MLS group") + schema + <*> fmap (.epochTimestamp) + .= maybe_ + ( optFieldWithDocModifier + "epoch_timestamp" + (description ?~ "The timestamp of the epoch number") + utcTimeSchema + ) + <*> maybe MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 (.ciphersuite) + .= fieldWithDocModifier + "cipher_suite" + (description ?~ "The cipher suite of the corresponding MLS group") + schema + where + mk :: Epoch -> Maybe UTCTime -> CipherSuiteTag -> Maybe ActiveMLSConversationData + mk (Epoch 0) _ _ = Nothing + mk epoch ts cs = ActiveMLSConversationData epoch <$> ts <*> pure cs +optionalActiveMLSConversationDataSchema _ = + mk + <$> maybe (Epoch 0) (.epoch) + .= fieldWithDocModifier + "epoch" + (description ?~ "The epoch number of the corresponding MLS group") + schema + <*> fmap (.epochTimestamp) + .= maybe_ + ( optFieldWithDocModifier + "epoch_timestamp" + (description ?~ "The timestamp of the epoch number") + utcTimeSchema + ) + <*> fmap (.ciphersuite) + .= maybe_ + ( optFieldWithDocModifier + "cipher_suite" + (description ?~ "The cipher suite of the corresponding MLS group") + schema + ) + where + mk :: Epoch -> Maybe UTCTime -> Maybe CipherSuiteTag -> Maybe ActiveMLSConversationData + mk (Epoch 0) _ _ = Nothing + mk epoch ts cs = ActiveMLSConversationData epoch <$> ts <*> cs + +instance ToSchema ConversationMLSData where + schema = object "ConversationMLSData" (mlsDataSchema Nothing) + +instance ToSchema (Versioned 'V5 ConversationMLSData) where + schema = Versioned <$> object "ConversationMLSDataV5" (unVersioned .= mlsDataSchema (Just V5)) + +-- TODO: Fix API compatibility +data ActiveMLSConversationData = ActiveMLSConversationData + { -- | The current epoch number of the corresponding MLS group. + epoch :: Epoch, + -- | The time stamp of the epoch. + epochTimestamp :: UTCTime, + -- | The cipher suite to be used in the MLS group. + ciphersuite :: CipherSuiteTag + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform ActiveMLSConversationData + deriving (ToJSON, FromJSON) via Schema ActiveMLSConversationData + +instance ToSchema ActiveMLSConversationData where + schema = object "ActiveMLSConversationData" activeMLSConversationDataSchema + +activeMLSConversationDataSchema :: ObjectSchema SwaggerDoc ActiveMLSConversationData +activeMLSConversationDataSchema = + ActiveMLSConversationData + <$> (.epoch) .= fieldWithDocModifier "epoch" (description ?~ "The epoch number of the corresponding MLS group") schema - <*> cnvmlsEpochTimestamp + <*> (.epochTimestamp) .= fieldWithDocModifier "epoch_timestamp" (description ?~ "The timestamp of the epoch number") - schemaEpochTimestamp - <*> cnvmlsCipherSuite + utcTimeSchema + <*> (.ciphersuite) .= fieldWithDocModifier "cipher_suite" (description ?~ "The cipher suite of the corresponding MLS group") schema -instance ToSchema ConversationMLSData where - schema = object "ConversationMLSData" mlsDataSchema - -- | Conversation protocol and protocol-specific data. data Protocol = ProtocolProteus @@ -145,16 +240,16 @@ deriving via (Schema ProtocolTag) instance ToJSON ProtocolTag protocolTagSchema :: ObjectSchema SwaggerDoc ProtocolTag protocolTagSchema = fmap (fromMaybe ProtocolProteusTag) (optField "protocol" schema) -protocolSchema :: ObjectSchema SwaggerDoc Protocol -protocolSchema = +protocolSchema :: Maybe Version -> ObjectSchema SwaggerDoc Protocol +protocolSchema v = snd <$> (protocolTag &&& id) .= bind (fst .= protocolTagSchema) - (snd .= dispatch protocolDataSchema) + (snd .= dispatch (protocolDataSchema v)) instance ToSchema Protocol where - schema = object "Protocol" protocolSchema + schema = object "Protocol" (protocolSchema Nothing) deriving via (Schema Protocol) instance FromJSON Protocol @@ -162,10 +257,10 @@ deriving via (Schema Protocol) instance ToJSON Protocol deriving via (Schema Protocol) instance S.ToSchema Protocol -protocolDataSchema :: ProtocolTag -> ObjectSchema SwaggerDoc Protocol -protocolDataSchema ProtocolProteusTag = tag _ProtocolProteus (pure ()) -protocolDataSchema ProtocolMLSTag = tag _ProtocolMLS mlsDataSchema -protocolDataSchema ProtocolMixedTag = tag _ProtocolMixed mlsDataSchema +protocolDataSchema :: Maybe Version -> ProtocolTag -> ObjectSchema SwaggerDoc Protocol +protocolDataSchema _ ProtocolProteusTag = tag _ProtocolProteus (pure ()) +protocolDataSchema v ProtocolMLSTag = tag _ProtocolMLS (mlsDataSchema v) +protocolDataSchema v ProtocolMixedTag = tag _ProtocolMixed (mlsDataSchema v) newtype ProtocolUpdate = ProtocolUpdate {unProtocolUpdate :: ProtocolTag} deriving (Show, Eq, Generic) diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index 7b3dcca7b63..f06e8d62973 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -393,10 +393,10 @@ taggedEventDataSchema = ConvAccessUpdate -> tag _EdConvAccessUpdate - (unnamed (conversationAccessDataSchema V2)) + (unnamed (conversationAccessDataSchema (Just V2))) ConvCodeUpdate -> tag _EdConvCodeUpdate (unnamed schema) ConvConnect -> tag _EdConnect (unnamed schema) - ConvCreate -> tag _EdConversation (unnamed (conversationSchema V2)) + ConvCreate -> tag _EdConversation (unnamed (conversationSchema (Just V2))) ConvMessageTimerUpdate -> tag _EdConvMessageTimerUpdate (unnamed schema) ConvReceiptModeUpdate -> tag _EdConvReceiptModeUpdate (unnamed schema) OtrMessageAdd -> tag _EdOtrMessage (unnamed schema) diff --git a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs index 043984800ac..ca8a5552f0f 100644 --- a/libs/wire-api/src/Wire/API/MLS/SubConversation.hs +++ b/libs/wire-api/src/Wire/API/MLS/SubConversation.hs @@ -21,6 +21,7 @@ module Wire.API.MLS.SubConversation where +import Control.Applicative import Control.Lens (makePrisms, (?~)) import Control.Lens.Tuple (_1) import Control.Monad.Except @@ -28,20 +29,19 @@ import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson qualified as A import Data.ByteString.Conversion import Data.Id -import Data.Json.Util import Data.OpenApi qualified as S import Data.Qualified import Data.Schema hiding (HasField) import Data.Text qualified as T -import Data.Time.Clock import GHC.Records import Imports import Servant (FromHttpApiData (..), ToHttpApiData (toQueryParam)) import Test.QuickCheck -import Wire.API.MLS.CipherSuite +import Wire.API.Conversation.Protocol import Wire.API.MLS.Credential -import Wire.API.MLS.Epoch import Wire.API.MLS.Group +import Wire.API.Routes.Version +import Wire.API.Routes.Versioned import Wire.Arbitrary -- | An MLS subconversation ID, which identifies a subconversation within a @@ -75,33 +75,29 @@ data PublicSubConversation = PublicSubConversation { pscParentConvId :: Qualified ConvId, pscSubConvId :: SubConvId, pscGroupId :: GroupId, - pscEpoch :: Epoch, - -- | It is 'Nothing' when the epoch is 0, and otherwise a timestamp when the - -- epoch was bumped, i.e., it is a timestamp of the most recent commit. - pscEpochTimestamp :: Maybe UTCTime, - pscCipherSuite :: CipherSuiteTag, + pscActiveData :: Maybe ActiveMLSConversationData, pscMembers :: [ClientIdentity] } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema PublicSubConversation) +publicSubConversationSchema :: Maybe Version -> ValueSchema NamedSwaggerDoc PublicSubConversation +publicSubConversationSchema v = + objectWithDocModifier + ("PublicSubConversation" <> foldMap (T.toUpper . versionText) v) + (description ?~ "An MLS subconversation") + $ PublicSubConversation + <$> pscParentConvId .= field "parent_qualified_id" schema + <*> pscSubConvId .= field "subconv_id" schema + <*> pscGroupId .= field "group_id" schema + <*> pscActiveData .= optionalActiveMLSConversationDataSchema v + <*> pscMembers .= field "members" (array schema) + instance ToSchema PublicSubConversation where - schema = - objectWithDocModifier - "PublicSubConversation" - (description ?~ "An MLS subconversation") - $ PublicSubConversation - <$> pscParentConvId .= field "parent_qualified_id" schema - <*> pscSubConvId .= field "subconv_id" schema - <*> pscGroupId .= field "group_id" schema - <*> pscEpoch .= field "epoch" schema - <*> pscEpochTimestamp .= field "epoch_timestamp" schemaEpochTimestamp - <*> pscCipherSuite .= field "cipher_suite" schema - <*> pscMembers .= field "members" (array schema) - -schemaEpochTimestamp :: ValueSchema NamedSwaggerDoc (Maybe UTCTime) -schemaEpochTimestamp = - named "Epoch Timestamp" . nullable . unnamed $ utcTimeSchema + schema = publicSubConversationSchema Nothing + +instance ToSchema (Versioned 'V5 PublicSubConversation) where + schema = Versioned <$> unVersioned .= publicSubConversationSchema (Just V5) data ConvOrSubTag = ConvTag | SubConvTag deriving (Eq, Enum, Bounded) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index d07f48258dc..c68dc51a76b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -43,6 +43,7 @@ import Wire.API.Routes.Public import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Galley.Feature import Wire.API.Routes.QualifiedCapture +import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature import Wire.API.Team.Member @@ -226,7 +227,7 @@ type InternalAPIBase = :> "conversations" :> "connect" :> ReqBody '[Servant.JSON] Connect - :> ConversationVerb + :> ConversationVerb 'V6 Conversation ) -- This endpoint is meant for testing membership of a conversation :<|> Named diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 08da1c6adee..064dd35f673 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -48,9 +48,7 @@ import Wire.API.Routes.Version import Wire.API.Routes.Versioned import Wire.API.Team.Feature -type ConversationResponse = ResponseForExistedCreated Conversation - --- | A type similar to 'ConversationResponse' introduced to allow for a failure +-- | A type similar to 'ResponseForExistedCreated' introduced to allow for a failure -- to add remote members while creating a conversation or due to involved -- backends forming an incomplete graph. data CreateGroupConversationResponse @@ -72,50 +70,26 @@ instance type ConversationHeaders = '[DescHeader "Location" "Conversation ID" ConvId] -type ConversationVerb = - MultiVerb - 'POST - '[JSON] - '[ WithHeaders - ConversationHeaders - Conversation - (Respond 200 "Conversation existed" Conversation), - WithHeaders - ConversationHeaders - Conversation - (Respond 201 "Conversation created" Conversation) - ] - ConversationResponse +type family ConversationResponse r -type CreateGroupConversationVerb = - MultiVerb - 'POST - '[JSON] - '[ WithHeaders - ConversationHeaders - Conversation - (Respond 200 "Conversation existed" Conversation), - WithHeaders - ConversationHeaders - CreateGroupConversation - (Respond 201 "Conversation created" CreateGroupConversation) - ] - CreateGroupConversationResponse +type instance ConversationResponse Conversation = ResponseForExistedCreated Conversation + +type instance ConversationResponse CreateGroupConversation = CreateGroupConversationResponse -type ConversationV2Verb = +type ConversationVerb v r = MultiVerb 'POST '[JSON] '[ WithHeaders ConversationHeaders Conversation - (VersionedRespond 'V2 200 "Conversation existed" Conversation), + (VersionedRespond v 200 "Conversation existed" Conversation), WithHeaders ConversationHeaders - Conversation - (VersionedRespond 'V2 201 "Conversation created" Conversation) + r + (VersionedRespond v 201 "Conversation created" r) ] - ConversationResponse + (ConversationResponse r) type CreateConversationCodeVerb = MultiVerb @@ -177,9 +151,22 @@ type ConversationAPI = :> MultiVerb1 'GET '[JSON] (VersionedRespond 'V2 200 "Conversation" Conversation) ) :<|> Named - "get-conversation" + "get-conversation@v5" ( Summary "Get a conversation by ID" :> From 'V3 + :> Until 'V6 + :> MakesFederatedCall 'Galley "get-conversations" + :> CanThrow 'ConvNotFound + :> CanThrow 'ConvAccessDenied + :> ZLocalUser + :> "conversations" + :> QualifiedCapture "cnv" ConvId + :> MultiVerb1 'GET '[JSON] (VersionedRespond 'V5 200 "Conversation" Conversation) + ) + :<|> Named + "get-conversation" + ( Summary "Get a conversation by ID" + :> From 'V6 :> MakesFederatedCall 'Galley "get-conversations" :> CanThrow 'ConvNotFound :> CanThrow 'ConvAccessDenied @@ -340,10 +327,30 @@ type ConversationAPI = ) ) :<|> Named - "list-conversations" + "list-conversations@v5" ( Summary "Get conversation metadata for a list of conversation ids" :> MakesFederatedCall 'Galley "get-conversations" :> From 'V3 + :> Until 'V6 + :> ZLocalUser + :> "conversations" + :> "list" + :> ReqBody '[JSON] ListConversations + :> MultiVerb1 + 'POST + '[JSON] + ( VersionedRespond + 'V5 + 200 + "Conversation page" + ConversationsResponse + ) + ) + :<|> Named + "list-conversations" + ( Summary "Get conversation metadata for a list of conversation ids" + :> MakesFederatedCall 'Galley "get-conversations" + :> From 'V6 :> ZLocalUser :> "conversations" :> "list" @@ -389,7 +396,7 @@ type ConversationAPI = :> ZOptConn :> "conversations" :> VersionedReqBody 'V2 '[Servant.JSON] NewConv - :> ConversationV2Verb + :> ConversationVerb 'V2 Conversation ) :<|> Named "create-group-conversation@v3" @@ -413,16 +420,17 @@ type ConversationAPI = :> ZOptConn :> "conversations" :> ReqBody '[Servant.JSON] NewConv - :> ConversationVerb + :> ConversationVerb 'V3 Conversation ) :<|> Named - "create-group-conversation" + "create-group-conversation@v5" ( Summary "Create a new conversation" :> MakesFederatedCall 'Brig "api-version" :> MakesFederatedCall 'Brig "get-not-fully-connected-backends" :> MakesFederatedCall 'Galley "on-conversation-created" :> MakesFederatedCall 'Galley "on-conversation-updated" :> From 'V4 + :> Until 'V6 :> CanThrow 'ConvAccessDenied :> CanThrow 'MLSNonEmptyMemberList :> CanThrow 'MLSNotEnabled @@ -437,7 +445,31 @@ type ConversationAPI = :> ZOptConn :> "conversations" :> ReqBody '[Servant.JSON] NewConv - :> CreateGroupConversationVerb + :> ConversationVerb 'V5 CreateGroupConversation + ) + :<|> Named + "create-group-conversation" + ( Summary "Create a new conversation" + :> MakesFederatedCall 'Brig "api-version" + :> MakesFederatedCall 'Brig "get-not-fully-connected-backends" + :> MakesFederatedCall 'Galley "on-conversation-created" + :> MakesFederatedCall 'Galley "on-conversation-updated" + :> From 'V6 + :> CanThrow 'ConvAccessDenied + :> CanThrow 'MLSNonEmptyMemberList + :> CanThrow 'MLSNotEnabled + :> CanThrow 'NotConnected + :> CanThrow 'NotATeamMember + :> CanThrow OperationDenied + :> CanThrow 'MissingLegalholdConsent + :> CanThrow NonFederatingBackends + :> CanThrow UnreachableBackends + :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" + :> ZLocalUser + :> ZOptConn + :> "conversations" + :> ReqBody '[Servant.JSON] NewConv + :> ConversationVerb 'V6 CreateGroupConversation ) :<|> Named "create-self-conversation@v2" @@ -446,21 +478,50 @@ type ConversationAPI = :> ZLocalUser :> "conversations" :> "self" - :> ConversationV2Verb + :> ConversationVerb 'V2 Conversation ) :<|> Named - "create-self-conversation" + "create-self-conversation@v5" ( Summary "Create a self-conversation" :> From 'V3 + :> Until 'V6 :> ZLocalUser :> "conversations" :> "self" - :> ConversationVerb + :> ConversationVerb 'V5 Conversation ) :<|> Named - "get-mls-self-conversation" + "create-self-conversation" + ( Summary "Create a self-conversation" + :> From 'V6 + :> ZLocalUser + :> "conversations" + :> "self" + :> ConversationVerb 'V6 Conversation + ) + :<|> Named + "get-mls-self-conversation@v5" ( Summary "Get the user's MLS self-conversation" :> From 'V5 + :> Until 'V6 + :> ZLocalUser + :> "conversations" + :> "mls-self" + :> CanThrow 'MLSNotEnabled + :> MultiVerb1 + 'GET + '[JSON] + ( VersionedRespond + 'V5 + 200 + "The MLS self-conversation" + Conversation + ) + ) + :<|> Named + "get-mls-self-conversation" + ( Summary "Get the user's MLS self-conversation" + :> From 'V6 :> ZLocalUser :> "conversations" :> "mls-self" @@ -586,7 +647,7 @@ type ConversationAPI = :> "conversations" :> "one2one" :> VersionedReqBody 'V2 '[JSON] NewConv - :> ConversationV2Verb + :> ConversationVerb 'V2 Conversation ) :<|> Named "create-one-to-one-conversation" @@ -608,7 +669,20 @@ type ConversationAPI = :> "conversations" :> "one2one" :> ReqBody '[JSON] NewConv - :> ConversationVerb + :> ConversationVerb 'V3 Conversation + ) + :<|> Named + "get-one-to-one-mls-conversation@v5" + ( Summary "Get an MLS 1:1 conversation" + :> From 'V5 + :> Until 'V6 + :> ZLocalUser + :> CanThrow 'MLSNotEnabled + :> CanThrow 'NotConnected + :> "conversations" + :> "one2one" + :> QualifiedCapture "usr" UserId + :> MultiVerb1 'GET '[JSON] (VersionedRespond 'V5 200 "MLS 1-1 conversation" Conversation) ) :<|> Named "get-one-to-one-mls-conversation" diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs index fe6362cafec..f672efe25b7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Version.hs +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -31,6 +31,7 @@ module Wire.API.Routes.Version -- * Version Version (..), versionInt, + versionText, VersionNumber (..), VersionExp (..), supportedVersions, 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 c530bf3234b..8940de2043c 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 @@ -389,12 +389,26 @@ tests = testGroup "Golden: Conversation_user V2" $ testObjects [ (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_1, "testObject_Conversation_v2_user_1.json"), - (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_v2_user_2.json") + (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_v2_user_2.json"), + (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_3, "testObject_Conversation_v2_user_3.json"), + (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_4, "testObject_Conversation_v2_user_4.json"), + (Versioned @'V2 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_5, "testObject_Conversation_v2_user_5.json") + ], + testGroup "Golden: Conversation_user V5" $ + testObjects + [ (Versioned @'V5 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_1, "testObject_Conversation_v5_user_1.json"), + (Versioned @'V5 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_v5_user_2.json"), + (Versioned @'V5 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_3, "testObject_Conversation_v5_user_3.json"), + (Versioned @'V5 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_4, "testObject_Conversation_v5_user_4.json"), + (Versioned @'V5 Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_5, "testObject_Conversation_v5_user_5.json") ], testGroup "Golden: Conversation_user" $ testObjects [ (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_1, "testObject_Conversation_user_1.json"), - (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_user_2.json") + (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_user_2.json"), + (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_3, "testObject_Conversation_user_3.json"), + (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_4, "testObject_Conversation_user_4.json"), + (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_5, "testObject_Conversation_user_5.json") ], testGroup "Golden: NewConv_user V2" $ testObjects diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs index 516f8baae58..daf78e839bb 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs @@ -17,18 +17,28 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Golden.Generated.Conversation_user where +module Test.Wire.API.Golden.Generated.Conversation_user + ( testObject_Conversation_user_1, + testObject_Conversation_user_2, + testObject_Conversation_user_3, + testObject_Conversation_user_4, + testObject_Conversation_user_5, + ) +where import Data.Domain import Data.Id (Id (Id)) import Data.Misc (Milliseconds (Ms, ms)) import Data.Qualified import Data.Set qualified as Set +import Data.Time.Calendar +import Data.Time.Clock import Data.UUID qualified as UUID (fromString) import Imports import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role (parseRoleName) +import Wire.API.MLS.CipherSuite import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) domain :: Domain @@ -133,3 +143,152 @@ testObject_Conversation_user_2 = ] } } + +testObject_Conversation_user_3 :: Conversation +testObject_Conversation_user_3 = + Conversation + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, + cnvMetadata = + ConversationMetadata + { cnvmType = SelfConv, + cnvmCreator = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001"))), + cnvmAccess = + [ InviteAccess, + InviteAccess, + CodeAccess, + LinkAccess, + InviteAccess, + PrivateAccess, + LinkAccess, + CodeAccess, + CodeAccess, + LinkAccess, + PrivateAccess, + InviteAccess + ], + cnvmAccessRoles = Set.fromList [TeamMemberAccessRole, GuestAccessRole, ServiceAccessRole], + cnvmName = Just "", + cnvmTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000000"))), + cnvmMessageTimer = Just (Ms {ms = 1319272593797015}), + cnvmReceiptMode = Just (ReceiptMode {unReceiptMode = 2}) + }, + cnvMembers = + ConvMembers + { cmSelf = + Member + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, + memService = Nothing, + memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = True, + memHiddenRef = Just "", + memConvRoleName = + fromJust (parseRoleName "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj") + }, + cmOthers = [] + }, + cnvProtocol = + ProtocolMLS + ( ConversationMLSData + (GroupId "test_group") + ( Just + ( ActiveMLSConversationData + (Epoch 42) + timestamp + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ) + ) + ) + } + where + timestamp :: UTCTime + timestamp = UTCTime (fromGregorian 2023 1 17) (secondsToDiffTime 42) + +testObject_Conversation_user_4 :: Conversation +testObject_Conversation_user_4 = + Conversation + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, + cnvMetadata = + ConversationMetadata + { cnvmType = SelfConv, + cnvmCreator = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001"))), + cnvmAccess = + [ InviteAccess, + InviteAccess, + CodeAccess, + LinkAccess, + InviteAccess, + PrivateAccess, + LinkAccess, + CodeAccess, + CodeAccess, + LinkAccess, + PrivateAccess, + InviteAccess + ], + cnvmAccessRoles = Set.fromList [TeamMemberAccessRole, GuestAccessRole, ServiceAccessRole], + cnvmName = Just "", + cnvmTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000000"))), + cnvmMessageTimer = Just (Ms {ms = 1319272593797015}), + cnvmReceiptMode = Just (ReceiptMode {unReceiptMode = 2}) + }, + cnvMembers = + ConvMembers + { cmSelf = + Member + { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, + memService = Nothing, + memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Nothing, + memHidden = True, + memHiddenRef = Just "", + memConvRoleName = + fromJust (parseRoleName "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj") + }, + cmOthers = [] + }, + cnvProtocol = + ProtocolMLS + ( ConversationMLSData + (GroupId "test_group") + Nothing + ) + } + +testObject_Conversation_user_5 :: Conversation +testObject_Conversation_user_5 = + Conversation + { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) domain, + cnvMetadata = + ConversationMetadata + { cnvmType = One2OneConv, + cnvmCreator = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001"))), + cnvmAccess = [], + cnvmAccessRoles = Set.empty, + cnvmName = Just " 0", + cnvmTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002"))), + cnvmMessageTimer = Nothing, + cnvmReceiptMode = Just (ReceiptMode {unReceiptMode = -2}) + }, + cnvMembers = + ConvMembers + { cmSelf = + Member + { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) domain, + memService = Nothing, + memOtrMutedStatus = Nothing, + memOtrMutedRef = Nothing, + memOtrArchived = False, + memOtrArchivedRef = Just "", + memHidden = False, + memHiddenRef = Just "", + memConvRoleName = fromJust (parseRoleName "rhhdzf0j0njilixx0g0vzrp06b_5us") + }, + cmOthers = [] + }, + cnvProtocol = ProtocolProteus + } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index 9e41b29bf3a..ffb00e875b7 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -123,6 +123,8 @@ tests = [(testObject_ListConversations_1, "testObject_ListConversations_1.json")], testGroup "ConversationsResponse V2" $ testObjects [(Versioned @'V2 testObject_ConversationsResponse_1, "testObject_ConversationsResponse_v2_1.json")], + testGroup "ConversationsResponse V5" $ + testObjects [(Versioned @'V5 testObject_ConversationsResponse_1, "testObject_ConversationsResponse_v5_1.json")], testGroup "ConversationsResponse" $ testObjects [(testObject_ConversationsResponse_1, "testObject_ConversationsResponse_1.json")], testGroup "CreateScimToken" $ @@ -151,6 +153,15 @@ tests = (testObject_TeamSize_2, "testObject_TeamSize_2.json"), (testObject_TeamSize_3, "testObject_TeamSize_3.json") ], + testGroup "PublicSubConversationV5" $ + testObjects + [ ( Versioned @'V5 testObject_PublicSubConversation_1, + "testObject_PublicSubConversation_v5_1.json" + ), + ( Versioned @'V5 testObject_PublicSubConversation_2, + "testObject_PublicSubConversation_v5_2.json" + ) + ], testGroup "PublicSubConversation" $ testObjects [ (testObject_PublicSubConversation_1, "testObject_PublicSubConversation_1.json"), diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs index 0a7b0342409..8fa36355f5b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs @@ -22,17 +22,11 @@ where import Data.Domain import Data.Id (Id (Id)) -import Data.Misc import Data.Qualified -import Data.Set qualified as Set -import Data.Time.Calendar -import Data.Time.Clock import Data.UUID qualified as UUID import Imports +import Test.Wire.API.Golden.Generated.Conversation_user import Wire.API.Conversation -import Wire.API.Conversation.Protocol -import Wire.API.Conversation.Role -import Wire.API.MLS.CipherSuite domain :: Domain domain = Domain "golden.example.com" @@ -40,7 +34,7 @@ domain = Domain "golden.example.com" testObject_ConversationsResponse_1 :: ConversationsResponse testObject_ConversationsResponse_1 = ConversationsResponse - { crFound = [conv1, conv2], + { crFound = [testObject_Conversation_user_5, testObject_Conversation_user_3], crNotFound = [ Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-000e00000002"))) domain, Qualified (Id (fromJust (UUID.fromString "00000018-0000-0020-0000-111111111112"))) (Domain "golden2.example.com") @@ -50,95 +44,3 @@ testObject_ConversationsResponse_1 = Qualified (Id (fromJust (UUID.fromString "99999999-0000-0020-0000-111111111112"))) (Domain "golden3.example.com") ] } - -conv1 :: Conversation -conv1 = - Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000"))) domain, - cnvMetadata = - ConversationMetadata - { cnvmType = One2OneConv, - cnvmCreator = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001"))), - cnvmAccess = [], - cnvmAccessRoles = Set.empty, - cnvmName = Just " 0", - cnvmTeam = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002"))), - cnvmMessageTimer = Nothing, - cnvmReceiptMode = Just (ReceiptMode {unReceiptMode = -2}) - }, - cnvMembers = - ConvMembers - { cmSelf = - Member - { memId = Qualified (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))) domain, - memService = Nothing, - memOtrMutedStatus = Nothing, - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Just "", - memHidden = False, - memHiddenRef = Just "", - memConvRoleName = fromJust (parseRoleName "rhhdzf0j0njilixx0g0vzrp06b_5us") - }, - cmOthers = [] - }, - cnvProtocol = ProtocolProteus - } - -conv2 :: Conversation -conv2 = - Conversation - { cnvQualifiedId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002"))) domain, - cnvMetadata = - ConversationMetadata - { cnvmType = SelfConv, - cnvmCreator = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000001"))), - cnvmAccess = - [ InviteAccess, - InviteAccess, - CodeAccess, - LinkAccess, - InviteAccess, - PrivateAccess, - LinkAccess, - CodeAccess, - CodeAccess, - LinkAccess, - PrivateAccess, - InviteAccess - ], - cnvmAccessRoles = Set.fromList [TeamMemberAccessRole, GuestAccessRole, ServiceAccessRole], - cnvmName = Just "", - cnvmTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000000"))), - cnvmMessageTimer = Just (Ms {ms = 1319272593797015}), - cnvmReceiptMode = Just (ReceiptMode {unReceiptMode = 2}) - }, - cnvMembers = - ConvMembers - { cmSelf = - Member - { memId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))) domain, - memService = Nothing, - memOtrMutedStatus = Just (MutedStatus {fromMutedStatus = -1}), - memOtrMutedRef = Nothing, - memOtrArchived = False, - memOtrArchivedRef = Nothing, - memHidden = True, - memHiddenRef = Just "", - memConvRoleName = - fromJust (parseRoleName "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj") - }, - cmOthers = [] - }, - cnvProtocol = - ProtocolMLS - ( ConversationMLSData - (GroupId "test_group") - (Epoch 42) - (Just timestamp) - MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - ) - } - where - timestamp :: UTCTime - timestamp = UTCTime (fromGregorian 2023 1 17) (secondsToDiffTime 42) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs index 72810686d4b..eda0dcb51aa 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/SubConversation.hs @@ -28,9 +28,9 @@ import Data.Time.Calendar import Data.Time.Clock import Data.UUID qualified as UUID import Imports +import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential -import Wire.API.MLS.Epoch import Wire.API.MLS.Group import Wire.API.MLS.SubConversation @@ -56,9 +56,13 @@ testObject_PublicSubConversation_1 = convId subConvId1 (GroupId "test_group") - (Epoch 5) - (Just (UTCTime day fromMidnight)) - MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ( Just + ( ActiveMLSConversationData + (Epoch 5) + (UTCTime day fromMidnight) + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + ) + ) [] where fromMidnight :: DiffTime @@ -72,9 +76,7 @@ testObject_PublicSubConversation_2 = convId subConvId2 (GroupId "test_group_2") - (Epoch 0) Nothing - MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 [mkClientIdentity user cid] where user :: Qualified UserId diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_3.json b/libs/wire-api/test/golden/testObject_Conversation_user_3.json new file mode 100644 index 00000000000..bdc0413d26a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_user_3.json @@ -0,0 +1,60 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 42, + "epoch_timestamp": "2023-01-17T00:00:42Z", + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_4.json b/libs/wire-api/test/golden/testObject_Conversation_user_4.json new file mode 100644 index 00000000000..3d6616cf602 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_user_4.json @@ -0,0 +1,58 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 0, + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_user_5.json b/libs/wire-api/test/golden/testObject_Conversation_user_5.json new file mode 100644 index 00000000000..e9c08330a13 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_user_5.json @@ -0,0 +1,39 @@ +{ + "access": [], + "access_role": [], + "creator": "00000001-0000-0001-0000-000200000001", + "id": "00000001-0000-0000-0000-000000000000", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "rhhdzf0j0njilixx0g0vzrp06b_5us", + "hidden": false, + "hidden_ref": "", + "id": "00000001-0000-0001-0000-000100000000", + "otr_archived": false, + "otr_archived_ref": "", + "otr_muted_ref": null, + "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": null, + "name": " 0", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000000" + }, + "receipt_mode": -2, + "team": "00000001-0000-0001-0000-000100000002", + "type": 2 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v2_user_3.json b/libs/wire-api/test/golden/testObject_Conversation_v2_user_3.json new file mode 100644 index 00000000000..7f4502a0adb --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v2_user_3.json @@ -0,0 +1,61 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": "non_activated", + "access_role_v2": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 42, + "epoch_timestamp": "2023-01-17T00:00:42Z", + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v2_user_4.json b/libs/wire-api/test/golden/testObject_Conversation_v2_user_4.json new file mode 100644 index 00000000000..6609a65f3af --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v2_user_4.json @@ -0,0 +1,60 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": "non_activated", + "access_role_v2": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 0, + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v2_user_5.json b/libs/wire-api/test/golden/testObject_Conversation_v2_user_5.json new file mode 100644 index 00000000000..90e837c0700 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v2_user_5.json @@ -0,0 +1,40 @@ +{ + "access": [], + "access_role": "private", + "access_role_v2": [], + "creator": "00000001-0000-0001-0000-000200000001", + "id": "00000001-0000-0000-0000-000000000000", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "rhhdzf0j0njilixx0g0vzrp06b_5us", + "hidden": false, + "hidden_ref": "", + "id": "00000001-0000-0001-0000-000100000000", + "otr_archived": false, + "otr_archived_ref": "", + "otr_muted_ref": null, + "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": null, + "name": " 0", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000000" + }, + "receipt_mode": -2, + "team": "00000001-0000-0001-0000-000100000002", + "type": 2 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v5_user_1.json b/libs/wire-api/test/golden/testObject_Conversation_v5_user_1.json new file mode 100644 index 00000000000..e9c08330a13 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v5_user_1.json @@ -0,0 +1,39 @@ +{ + "access": [], + "access_role": [], + "creator": "00000001-0000-0001-0000-000200000001", + "id": "00000001-0000-0000-0000-000000000000", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "rhhdzf0j0njilixx0g0vzrp06b_5us", + "hidden": false, + "hidden_ref": "", + "id": "00000001-0000-0001-0000-000100000000", + "otr_archived": false, + "otr_archived_ref": "", + "otr_muted_ref": null, + "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": null, + "name": " 0", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000000" + }, + "receipt_mode": -2, + "team": "00000001-0000-0001-0000-000100000002", + "type": 2 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v5_user_2.json b/libs/wire-api/test/golden/testObject_Conversation_v5_user_2.json new file mode 100644 index 00000000000..bc75e888889 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v5_user_2.json @@ -0,0 +1,70 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "creator": "00000000-0000-0000-0000-000200000001", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [ + { + "conversation_role": "r1rg526serx51g15n99y1bw_9q0qrcwck3jxl7ocjsjqcoux7d1zbkz9nnczy92t2oyogxrx3cyh_b8yv44l61mx9uzdnv6", + "id": "00000001-0000-0001-0000-000100000001", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000001" + }, + "service": { + "id": "00000001-0000-0000-0000-000000000000", + "provider": "00000001-0000-0000-0000-000000000001" + }, + "status": 0 + } + ], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": null, + "team": null, + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v5_user_3.json b/libs/wire-api/test/golden/testObject_Conversation_v5_user_3.json new file mode 100644 index 00000000000..bdc0413d26a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v5_user_3.json @@ -0,0 +1,60 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 42, + "epoch_timestamp": "2023-01-17T00:00:42Z", + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v5_user_4.json b/libs/wire-api/test/golden/testObject_Conversation_v5_user_4.json new file mode 100644 index 00000000000..430ac682cee --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v5_user_4.json @@ -0,0 +1,59 @@ +{ + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 0, + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 +} diff --git a/libs/wire-api/test/golden/testObject_Conversation_v5_user_5.json b/libs/wire-api/test/golden/testObject_Conversation_v5_user_5.json new file mode 100644 index 00000000000..e9c08330a13 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Conversation_v5_user_5.json @@ -0,0 +1,39 @@ +{ + "access": [], + "access_role": [], + "creator": "00000001-0000-0001-0000-000200000001", + "id": "00000001-0000-0000-0000-000000000000", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "rhhdzf0j0njilixx0g0vzrp06b_5us", + "hidden": false, + "hidden_ref": "", + "id": "00000001-0000-0001-0000-000100000000", + "otr_archived": false, + "otr_archived_ref": "", + "otr_muted_ref": null, + "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": null, + "name": " 0", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000000" + }, + "receipt_mode": -2, + "team": "00000001-0000-0001-0000-000100000002", + "type": 2 +} diff --git a/libs/wire-api/test/golden/testObject_ConversationsResponse_v5_1.json b/libs/wire-api/test/golden/testObject_ConversationsResponse_v5_1.json new file mode 100644 index 00000000000..1156816764e --- /dev/null +++ b/libs/wire-api/test/golden/testObject_ConversationsResponse_v5_1.json @@ -0,0 +1,123 @@ +{ + "failed": [ + { + "domain": "golden.example.com", + "id": "00000018-4444-0020-0000-000e00000002" + }, + { + "domain": "golden3.example.com", + "id": "99999999-0000-0020-0000-111111111112" + } + ], + "found": [ + { + "access": [], + "access_role": [], + "creator": "00000001-0000-0001-0000-000200000001", + "id": "00000001-0000-0000-0000-000000000000", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "rhhdzf0j0njilixx0g0vzrp06b_5us", + "hidden": false, + "hidden_ref": "", + "id": "00000001-0000-0001-0000-000100000000", + "otr_archived": false, + "otr_archived_ref": "", + "otr_muted_ref": null, + "otr_muted_status": null, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0001-0000-000100000000" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": null, + "name": " 0", + "protocol": "proteus", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000001-0000-0000-0000-000000000000" + }, + "receipt_mode": -2, + "team": "00000001-0000-0001-0000-000100000002", + "type": 2 + }, + { + "access": [ + "invite", + "invite", + "code", + "link", + "invite", + "private", + "link", + "code", + "code", + "link", + "private", + "invite" + ], + "access_role": [ + "team_member", + "guest", + "service" + ], + "cipher_suite": 1, + "creator": "00000000-0000-0000-0000-000200000001", + "epoch": 42, + "epoch_timestamp": "2023-01-17T00:00:42Z", + "group_id": "dGVzdF9ncm91cA==", + "id": "00000000-0000-0000-0000-000000000002", + "last_event": "0.0", + "last_event_time": "1970-01-01T00:00:00.000Z", + "members": { + "others": [], + "self": { + "conversation_role": "9b2d3thyqh4ptkwtq2n2v9qsni_ln1ca66et_z8dlhfs9oamp328knl3rj9kcj", + "hidden": true, + "hidden_ref": "", + "id": "00000000-0000-0001-0000-000100000001", + "otr_archived": false, + "otr_archived_ref": null, + "otr_muted_ref": null, + "otr_muted_status": -1, + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "service": null, + "status": 0, + "status_ref": "0.0", + "status_time": "1970-01-01T00:00:00.000Z" + } + }, + "message_timer": 1319272593797015, + "name": "", + "protocol": "mls", + "qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000000000002" + }, + "receipt_mode": 2, + "team": "00000000-0000-0001-0000-000200000000", + "type": 1 + } + ], + "not_found": [ + { + "domain": "golden.example.com", + "id": "00000018-0000-0020-0000-000e00000002" + }, + { + "domain": "golden2.example.com", + "id": "00000018-0000-0020-0000-111111111112" + } + ] +} diff --git a/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json b/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json index a918c3161ba..64914b82b12 100644 --- a/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json +++ b/libs/wire-api/test/golden/testObject_PublicSubConversation_2.json @@ -1,7 +1,5 @@ { - "cipher_suite": 1, "epoch": 0, - "epoch_timestamp": null, "group_id": "dGVzdF9ncm91cF8y", "members": [ { diff --git a/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_1.json b/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_1.json new file mode 100644 index 00000000000..05ce835507a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_1.json @@ -0,0 +1,12 @@ +{ + "cipher_suite": 1, + "epoch": 5, + "epoch_timestamp": "2023-01-17T00:00:42Z", + "group_id": "dGVzdF9ncm91cA==", + "members": [], + "parent_qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "subconv_id": "test_group" +} diff --git a/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_2.json b/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_2.json new file mode 100644 index 00000000000..ac57e7e8e1b --- /dev/null +++ b/libs/wire-api/test/golden/testObject_PublicSubConversation_v5_2.json @@ -0,0 +1,17 @@ +{ + "cipher_suite": 1, + "epoch": 0, + "group_id": "dGVzdF9ncm91cF8y", + "members": [ + { + "client_id": "deadbeef", + "domain": "golden.example.com", + "user_id": "00000000-0000-0007-0000-000a00000002" + } + ], + "parent_qualified_id": { + "domain": "golden.example.com", + "id": "00000000-0000-0001-0000-000100000001" + }, + "subconv_id": "call" +} diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 2df5b92e5c8..b998a108339 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -70,6 +70,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation qualified as Public import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -116,7 +117,7 @@ createGroupConversationUpToV3 :: Local UserId -> Maybe ConnId -> NewConv -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do conv <- @@ -291,13 +292,13 @@ createProteusSelfConversation :: Member P.TinyLog r ) => Local UserId -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createProteusSelfConversation lusr = do let lcnv = fmap Data.selfConv lusr c <- E.getConversation (tUnqualified lcnv) maybe (create lcnv) (conversationExisted lusr) c where - create :: Local ConvId -> Sem r ConversationResponse + create :: Local ConvId -> Sem r (ConversationResponse Public.Conversation) create lcnv = do let nc = NewConversation @@ -332,7 +333,7 @@ createOne2OneConversation :: Local UserId -> ConnId -> NewConv -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createOne2OneConversation lusr zcon j = mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackendsLegacy $ do let allUsers = newConvMembers lusr j @@ -402,7 +403,7 @@ createLegacyOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Local UserId -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other let meta = @@ -445,7 +446,7 @@ createOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -471,7 +472,7 @@ createOne2OneConversationLocally :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createOne2OneConversationLocally lcnv self zcon name mtid other = do mc <- E.getConversation (tUnqualified lcnv) case mc of @@ -501,7 +502,7 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createOne2OneConversationRemotely _ _ _ _ _ _ = throw FederationNotImplemented @@ -523,7 +524,7 @@ createConnectConversation :: Local UserId -> Maybe ConnId -> Connect -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) createConnectConversation lusr conn j = do lrecipient <- ensureLocal lusr (cRecipient j) n <- rangeCheckedMaybe (cName j) @@ -645,7 +646,7 @@ conversationCreated :: ) => Local UserId -> Data.Conversation -> - Sem r ConversationResponse + Sem r (ConversationResponse Public.Conversation) conversationCreated lusr cnv = Created <$> conversationView lusr cnv -- | The return set contains all the remote users that could not be contacted. diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs index 0386d3d4738..1c7b97f6b89 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -31,6 +31,7 @@ import Data.Qualified import Data.Time import Galley.API.Error import Galley.API.MLS.Conversation +import Galley.API.MLS.IncomingMessage import Galley.API.MLS.Proposal import Galley.API.MLS.Types import Galley.Effects @@ -59,6 +60,7 @@ import Wire.API.Federation.Version import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Credential +import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.User.Client import Wire.NotificationSubsystem @@ -99,9 +101,10 @@ getCommitData :: ClientIdentity -> Local ConvOrSubConv -> Epoch -> - Commit -> + CipherSuiteTag -> + IncomingBundle -> Sem r ProposalAction -getCommitData senderIdentity lConvOrSub epoch commit = do +getCommitData senderIdentity lConvOrSub epoch ciphersuite bundle = do let convOrSub = tUnqualified lConvOrSub groupId = cnvmlsGroupId convOrSub.mlsMeta @@ -110,8 +113,11 @@ getCommitData senderIdentity lConvOrSub epoch commit = do if epoch == Epoch 0 then addProposedClient senderIdentity else mempty - proposals <- traverse (derefOrCheckProposal convOrSub.mlsMeta groupId epoch) commit.proposals - action <- applyProposals convOrSub.mlsMeta groupId proposals + proposals <- + traverse + (derefOrCheckProposal epoch ciphersuite groupId) + bundle.commit.value.proposals + action <- applyProposals ciphersuite groupId proposals pure (creatorAction <> action) incrementEpoch :: diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs index 364feaf5ce2..52b5a447ca8 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs @@ -42,6 +42,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Federation.Error +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.LeafNode @@ -70,8 +71,11 @@ getExternalCommitData :: Sem r ExternalCommitAction getExternalCommitData senderIdentity lConvOrSub epoch commit = do let convOrSub = tUnqualified lConvOrSub - curEpoch = cnvmlsEpoch convOrSub.mlsMeta groupId = cnvmlsGroupId convOrSub.mlsMeta + activeData <- + note (mlsProtocolError "The first commit in a group cannot be external") $ + cnvmlsActiveData convOrSub.mlsMeta + let curEpoch = activeData.epoch when (epoch /= curEpoch) $ throwS @'MLSStaleMessage when (epoch == Epoch 0) $ throw $ @@ -95,7 +99,7 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do evalState convOrSub.indexMap $ do -- process optional removal - propAction <- applyProposals convOrSub.mlsMeta groupId proposals + propAction <- applyProposals activeData.ciphersuite groupId proposals removedIndex <- case cmAssocs (paRemove propAction) of [(cid, idx)] | cid /= senderIdentity -> @@ -130,11 +134,12 @@ processExternalCommit :: ) => ClientIdentity -> Local ConvOrSubConv -> + CipherSuiteTag -> Epoch -> ExternalCommitAction -> Maybe UpdatePath -> Sem r () -processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do +processExternalCommit senderIdentity lConvOrSub ciphersuite epoch action updatePath = do let convOrSub = tUnqualified lConvOrSub -- only members can join a subconversation @@ -148,10 +153,9 @@ processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do <$> note (mlsProtocolError "External commits need an update path") updatePath - let cs = cnvmlsCipherSuite (tUnqualified lConvOrSub).mlsMeta let groupId = cnvmlsGroupId convOrSub.mlsMeta let extra = LeafNodeTBSExtraCommit groupId action.add - case validateLeafNode cs (Just senderIdentity) extra leafNode.value of + case validateLeafNode ciphersuite (Just senderIdentity) extra leafNode.value of Left errMsg -> throw $ mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg) diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs index 8a1bbe7fe21..4e7974de17d 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs @@ -54,6 +54,7 @@ import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.LeaveReason +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.Proposal qualified as Proposal @@ -76,15 +77,15 @@ processInternalCommit :: ClientIdentity -> Maybe ConnId -> Local ConvOrSubConv -> + CipherSuiteTag -> Epoch -> ProposalAction -> Commit -> Sem r [LocalConversationUpdate] -processInternalCommit senderIdentity con lConvOrSub epoch action commit = do +processInternalCommit senderIdentity con lConvOrSub ciphersuite epoch action commit = do let convOrSub = tUnqualified lConvOrSub qusr = cidQualifiedUser senderIdentity cm = convOrSub.members - suite = cnvmlsCipherSuite convOrSub.mlsMeta newUserClients = Map.assocs (paAdd action) -- check all pending proposals are referenced in the commit @@ -154,7 +155,7 @@ processInternalCommit senderIdentity con lConvOrSub epoch action commit = do -- final set of clients in the conversation let clients = Map.keysSet (newclients <> Map.findWithDefault mempty qtarget cm) -- get list of mls clients from Brig (local or remote) - getClientInfo lConvOrSub qtarget suite >>= \case + getClientInfo lConvOrSub qtarget ciphersuite >>= \case Left _e -> pure (Just qtarget) Right clientInfo -> do let allClients = Set.map ciId clientInfo @@ -192,7 +193,6 @@ processInternalCommit senderIdentity con lConvOrSub epoch action commit = do createSubConversation cnv sub - convOrSub.mlsMeta.cnvmlsCipherSuite convOrSub.mlsMeta.cnvmlsGroupId pure [] Conv _ diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 39c897665af..a4add447b06 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -204,39 +204,40 @@ postMLSCommitBundleToLocalConv :: Local ConvOrSubConvId -> Sem r [LocalConversationUpdate] postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do - lConvOrSub <- do - lConvOrSub <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId - let convOrSub = tUnqualified lConvOrSub - giCipherSuite <- - note (mlsProtocolError "Unsupported ciphersuite") $ - cipherSuiteTag bundle.groupInfo.value.groupContext.cipherSuite - let convCipherSuite = convOrSub.mlsMeta.cnvmlsCipherSuite + lConvOrSub <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId + let convOrSub = tUnqualified lConvOrSub + + ciphersuite <- + note (mlsProtocolError "Unsupported ciphersuite") $ + cipherSuiteTag bundle.groupInfo.value.groupContext.cipherSuite + + case convOrSub.mlsMeta.cnvmlsActiveData of -- if this is the first commit of the conversation, update ciphersuite - if (giCipherSuite == convCipherSuite) - then pure lConvOrSub - else do - unless (convOrSub.mlsMeta.cnvmlsEpoch == Epoch 0) $ - throw $ - mlsProtocolError "GroupInfo ciphersuite does not match conversation" - -- save to cassandra - case convOrSub.id of - Conv cid -> setConversationCipherSuite cid giCipherSuite - SubConv cid sub -> - setSubConversationCipherSuite cid sub giCipherSuite - pure $ fmap (convOrSubConvSetCipherSuite giCipherSuite) lConvOrSub + Nothing -> do + case convOrSub.id of + Conv cid -> setConversationCipherSuite cid ciphersuite + SubConv cid sub -> setSubConversationCipherSuite cid sub ciphersuite + -- otherwise, make sure the ciphersuite matches + Just activeData -> do + unless (ciphersuite == activeData.ciphersuite) $ + throw $ + mlsProtocolError "GroupInfo ciphersuite does not match conversation" + unless (bundle.epoch == activeData.epoch) $ throwS @'MLSStaleMessage senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub (events, newClients) <- case bundle.sender of SenderMember _index -> do -- extract added/removed clients from bundle - action <- getCommitData senderIdentity lConvOrSub bundle.epoch bundle.commit.value + action <- getCommitData senderIdentity lConvOrSub bundle.epoch ciphersuite bundle + -- process additions and removals events <- processInternalCommit senderIdentity conn lConvOrSub + ciphersuite bundle.epoch action bundle.commit.value @@ -251,6 +252,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do processExternalCommit senderIdentity lConvOrSub + ciphersuite bundle.epoch action bundle.commit.value.path @@ -405,11 +407,15 @@ postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do throwS @'MLSUnsupportedMessage -- reject application messages older than 2 epochs + -- FUTUREWORK: consider rejecting this message if the conversation epoch is 0 let epochInt :: Epoch -> Integer epochInt = fromIntegral . epochNumber - when - (epochInt msg.epoch < epochInt convOrSub.mlsMeta.cnvmlsEpoch - 2) - $ throwS @'MLSStaleMessage + case convOrSub.mlsMeta.cnvmlsActiveData of + Nothing -> throw $ mlsProtocolError "Application messages at epoch 0 are not supported" + Just activeData -> + when + (epochInt msg.epoch < epochInt activeData.epoch - 2) + $ throwS @'MLSStaleMessage propagateMessage qusr (Just c) lConvOrSub con msg.rawMessage (tUnqualified lConvOrSub).members pure [] @@ -489,7 +495,7 @@ fetchConvOrSub qusr groupId ctype convOrSubId = for convOrSubId $ \case c <- getMLSConv qusr Nothing ctype lconv msubconv <- getSubConversation convId sconvId subconv <- case msubconv of - Nothing -> pure $ newSubConversationFromParent lconv sconvId (mcMLSData c) + Nothing -> pure $ newSubConversationFromParent lconv sconvId Just subconv -> do when (groupId /= subconv.scMLSData.cnvmlsGroupId) $ throw (mlsProtocolError "The message group ID does not match the subconversation") diff --git a/services/galley/src/Galley/API/MLS/One2One.hs b/services/galley/src/Galley/API/MLS/One2One.hs index a5b01e129a3..462c0beb66f 100644 --- a/services/galley/src/Galley/API/MLS/One2One.hs +++ b/services/galley/src/Galley/API/MLS/One2One.hs @@ -36,7 +36,6 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Federation.API.Galley -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group.Serialisation import Wire.API.MLS.SubConversation import Wire.API.User @@ -92,9 +91,7 @@ localMLSOne2OneConversationMetadata convId = mlsData = ConversationMLSData { cnvmlsGroupId = groupId, - cnvmlsEpoch = Epoch 0, - cnvmlsEpochTimestamp = Nothing, - cnvmlsCipherSuite = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + cnvmlsActiveData = Nothing } in (metadata, mlsData) diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 4df31ac4c97..cbaba7f43db 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -60,6 +60,7 @@ import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Federation.Error import Wire.API.MLS.AuthenticatedContent +import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage import Wire.API.MLS.LeafNode @@ -146,28 +147,28 @@ derefOrCheckProposal :: Member (State IndexMap) r, Member (ErrorS 'MLSProposalNotFound) r ) => - ConversationMLSData -> - GroupId -> Epoch -> + CipherSuiteTag -> + GroupId -> ProposalOrRef -> Sem r Proposal -derefOrCheckProposal _mlsMeta groupId epoch (Ref ref) = do +derefOrCheckProposal epoch _ciphersuite groupId (Ref ref) = do p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound pure p.value -derefOrCheckProposal mlsMeta _ _ (Inline p) = do +derefOrCheckProposal _epoch ciphersuite _ (Inline p) = do im <- get - checkProposal mlsMeta im p + checkProposal ciphersuite im p pure p checkProposal :: ( Member (Error MLSProtocolError) r, Member (ErrorS 'MLSInvalidLeafNodeIndex) r ) => - ConversationMLSData -> + CipherSuiteTag -> IndexMap -> Proposal -> Sem r () -checkProposal mlsMeta im p = case p of +checkProposal ciphersuite im p = case p of AddProposal kp -> do (cs, _lifetime) <- either @@ -175,7 +176,7 @@ checkProposal mlsMeta im p = case p of pure $ validateKeyPackage Nothing kp.value -- we are not checking lifetime constraints here - unless (mlsMeta.cnvmlsCipherSuite == cs) $ + unless (ciphersuite == cs) $ throw (mlsProtocolError "Key package ciphersuite does not match conversation") RemoveProposal idx -> do void $ noteS @'MLSInvalidLeafNodeIndex $ imLookup im idx @@ -194,13 +195,13 @@ applyProposals :: Member (ErrorS 'MLSUnsupportedProposal) r, Member (ErrorS 'MLSInvalidLeafNodeIndex) r ) => - ConversationMLSData -> + CipherSuiteTag -> GroupId -> [Proposal] -> Sem r ProposalAction -applyProposals mlsMeta groupId = +applyProposals ciphersuite groupId = -- proposals are sorted before processing - foldMap (applyProposal mlsMeta groupId) + foldMap (applyProposal ciphersuite groupId) . sortOn proposalProcessingStage applyProposal :: @@ -209,27 +210,27 @@ applyProposal :: Member (ErrorS 'MLSUnsupportedProposal) r, Member (ErrorS 'MLSInvalidLeafNodeIndex) r ) => - ConversationMLSData -> + CipherSuiteTag -> GroupId -> Proposal -> Sem r ProposalAction -applyProposal mlsMeta _groupId (AddProposal kp) = do +applyProposal ciphersuite _groupId (AddProposal kp) = do (cs, _lifetime) <- either (\msg -> throw (mlsProtocolError ("Invalid key package in Add proposal: " <> msg))) pure $ validateKeyPackage Nothing kp.value - unless (mlsMeta.cnvmlsCipherSuite == cs) $ + unless (ciphersuite == cs) $ throw (mlsProtocolError "Key package ciphersuite does not match conversation") -- we are not checking lifetime constraints here cid <- getKeyPackageIdentity kp.value addProposedClient cid -applyProposal _mlsMeta _groupId (RemoveProposal idx) = do +applyProposal _ciphersuite _groupId (RemoveProposal idx) = do im <- get (cid, im') <- noteS @'MLSInvalidLeafNodeIndex $ imRemoveClient im idx put im' pure (paRemoveClient cid idx) -applyProposal _mlsMeta _groupId _ = pure mempty +applyProposal _activeData _groupId _ = pure mempty processProposal :: HasProposalEffects r => @@ -245,21 +246,23 @@ processProposal :: Sem r () processProposal qusr lConvOrSub groupId epoch pub prop = do let mlsMeta = (tUnqualified lConvOrSub).mlsMeta - -- Check if the epoch number matches that of a conversation - unless (epoch == cnvmlsEpoch mlsMeta) $ throwS @'MLSStaleMessage -- Check if the group ID matches that of a conversation unless (groupId == cnvmlsGroupId mlsMeta) $ throwS @'ConvNotFound - let suiteTag = cnvmlsCipherSuite mlsMeta - -- Reject proposals before first commit - when (mlsMeta.cnvmlsEpoch == Epoch 0) $ - throw (mlsProtocolError "Bare proposals at epoch 0 are not supported") + case cnvmlsActiveData mlsMeta of + Nothing -> throw $ mlsProtocolError "Bare proposals at epoch 0 are not supported" + Just activeData -> do + -- Check if the epoch number matches that of a conversation + unless (epoch == activeData.epoch) $ throwS @'MLSStaleMessage - -- FUTUREWORK: validate the member's conversation role - checkProposal mlsMeta (tUnqualified lConvOrSub).indexMap prop.value - when (isExternal pub.sender) $ checkExternalProposalUser qusr prop.value - let propRef = authContentRef suiteTag (incomingMessageAuthenticatedContent pub) - storeProposal groupId epoch propRef ProposalOriginClient prop + -- FUTUREWORK: validate the member's conversation role + checkProposal activeData.ciphersuite (tUnqualified lConvOrSub).indexMap prop.value + when (isExternal pub.sender) $ checkExternalProposalUser qusr prop.value + let propRef = + authContentRef + activeData.ciphersuite + (incomingMessageAuthenticatedContent pub) + storeProposal groupId epoch propRef ProposalOriginClient prop getKeyPackageIdentity :: Member (ErrorS 'MLSUnsupportedProposal) r => diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index 2b70748035a..53c9a4f2a97 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -87,9 +87,11 @@ createAndSendRemoveProposals :: -- conversation/subconversation client maps. ClientMap -> Sem r () -createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do +createAndSendRemoveProposals lConvOrSubConv indices qusr cm = void . runError @() $ do let meta = (tUnqualified lConvOrSubConv).mlsMeta - mKeyPair <- getMLSRemovalKey (csSignatureScheme (cnvmlsCipherSuite meta)) + activeData <- note () $ cnvmlsActiveData meta + let cs = activeData.ciphersuite + mKeyPair <- getMLSRemovalKey (csSignatureScheme cs) case mKeyPair of Nothing -> do warn $ Log.msg ("No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text) @@ -108,7 +110,7 @@ createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do storeProposal (cnvmlsGroupId meta) (cnvmlsEpoch meta) - (publicMessageRef (cnvmlsCipherSuite meta) pmsg) + (publicMessageRef cs pmsg) ProposalOriginBackend proposal propagateMessage qusr Nothing lConvOrSubConv Nothing msg cm diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 37a400a9672..af4df8a7482 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -120,7 +120,7 @@ getLocalSubConversation qusr lconv sconv = do msub <- Eff.getSubConversation (tUnqualified lconv) sconv sub <- case msub of Nothing -> do - (mlsMeta, mlsProtocol) <- noteS @'ConvNotFound (mlsMetadata c) + (_mlsMeta, mlsProtocol) <- noteS @'ConvNotFound (mlsMetadata c) case mlsProtocol of MLSMigrationMixed -> throwS @'MLSSubConvUnsupportedConvType @@ -128,7 +128,7 @@ getLocalSubConversation qusr lconv sconv = do -- deriving this deterministically to prevent race conditions with -- multiple threads creating the subconversation - pure (newSubConversationFromParent lconv sconv mlsMeta) + pure (newSubConversationFromParent lconv sconv) Just sub -> pure sub pure (toPublicSubConv (tUntagged (qualifyAs lconv sub))) @@ -263,10 +263,6 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do lConvOrSubId = qualifyAs lcnvId (SubConv cnvId scnvId) cnv <- getConversationAndCheckMembership qusr lcnvId - (mlsMeta, _mlsProtocol) <- noteS @'ConvNotFound (mlsMetadata cnv) - - let cs = cnvmlsCipherSuite mlsMeta - withCommitLock lConvOrSubId (dscGroupId dsc) (dscEpoch dsc) $ do sconv <- Eff.getSubConversation cnvId scnvId @@ -287,7 +283,7 @@ deleteLocalSubConversation qusr lcnvId scnvId dsc = do $ nextGenGroupId gid -- the following overwrites any prior information about the subconversation - void $ Eff.createSubConversation cnvId scnvId cs newGid + void $ Eff.createSubConversation cnvId scnvId newGid deleteRemoteSubConversation :: ( Members diff --git a/services/galley/src/Galley/API/MLS/Types.hs b/services/galley/src/Galley/API/MLS/Types.hs index 5cfce7bd88a..3274956f1bd 100644 --- a/services/galley/src/Galley/API/MLS/Types.hs +++ b/services/galley/src/Galley/API/MLS/Types.hs @@ -30,7 +30,6 @@ import Galley.Types.Conversations.Members import Imports import Wire.API.Conversation import Wire.API.Conversation.Protocol -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.Group.Serialisation import Wire.API.MLS.LeafNode @@ -148,17 +147,15 @@ data SubConversation = SubConversation } deriving (Eq, Show) -newSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> GroupId -> SubConversation -newSubConversation convId subConvId suite groupId = +newSubConversation :: ConvId -> SubConvId -> GroupId -> SubConversation +newSubConversation convId subConvId groupId = SubConversation { scParentConvId = convId, scSubConvId = subConvId, scMLSData = ConversationMLSData { cnvmlsGroupId = groupId, - cnvmlsEpoch = Epoch 0, - cnvmlsEpochTimestamp = Nothing, - cnvmlsCipherSuite = suite + cnvmlsActiveData = Nothing }, scMembers = mkClientMap [], scIndexMap = mempty @@ -167,15 +164,13 @@ newSubConversation convId subConvId suite groupId = newSubConversationFromParent :: Local ConvId -> SubConvId -> - ConversationMLSData -> SubConversation -newSubConversationFromParent lconv sconv mlsMeta = +newSubConversationFromParent lconv sconv = let groupId = convToGroupId . groupIdParts RegularConv $ flip SubConv sconv <$> tUntagged lconv - suite = cnvmlsCipherSuite mlsMeta - in newSubConversation (tUnqualified lconv) sconv suite groupId + in newSubConversation (tUnqualified lconv) sconv groupId toPublicSubConv :: Qualified SubConversation -> PublicSubConversation toPublicSubConv (Qualified (SubConversation {..}) domain) = @@ -184,9 +179,7 @@ toPublicSubConv (Qualified (SubConversation {..}) domain) = { pscParentConvId = Qualified scParentConvId domain, pscSubConvId = scSubConvId, pscGroupId = cnvmlsGroupId scMLSData, - pscEpoch = cnvmlsEpoch scMLSData, - pscEpochTimestamp = cnvmlsEpochTimestamp scMLSData, - pscCipherSuite = cnvmlsCipherSuite scMLSData, + pscActiveData = cnvmlsActiveData scMLSData, pscMembers = members } @@ -215,14 +208,8 @@ instance HasField "migrationState" ConvOrSubConv MLSMigrationState where getField (Conv c) = c.mcMigrationState getField (SubConv _ _) = MLSMigrationMLS -convOrSubConvSetCipherSuite :: CipherSuiteTag -> ConvOrSubConv -> ConvOrSubConv -convOrSubConvSetCipherSuite cs (Conv c) = - Conv $ - c - { mcMLSData = (mcMLSData c) {cnvmlsCipherSuite = cs} - } -convOrSubConvSetCipherSuite cs (SubConv c s) = - SubConv c $ - s - { scMLSData = (scMLSData s) {cnvmlsCipherSuite = cs} - } +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/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 6341091e356..487e6893c85 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -34,6 +34,7 @@ conversationAPI = mkNamedAPI @"get-unqualified-conversation" getUnqualifiedConversation <@> mkNamedAPI @"get-unqualified-conversation-legalhold-alias" getUnqualifiedConversation <@> mkNamedAPI @"get-conversation@v2" (callsFed (exposeAnnotations getConversation)) + <@> mkNamedAPI @"get-conversation@v5" (callsFed (exposeAnnotations getConversation)) <@> mkNamedAPI @"get-conversation" (callsFed (exposeAnnotations getConversation)) <@> mkNamedAPI @"get-conversation-roles" getConversationRoles <@> mkNamedAPI @"get-group-info" (callsFed (exposeAnnotations getGroupInfo)) @@ -43,13 +44,17 @@ conversationAPI = <@> mkNamedAPI @"get-conversations" getConversations <@> mkNamedAPI @"list-conversations@v1" (callsFed (exposeAnnotations listConversations)) <@> mkNamedAPI @"list-conversations@v2" (callsFed (exposeAnnotations listConversations)) + <@> mkNamedAPI @"list-conversations@v5" (callsFed (exposeAnnotations listConversations)) <@> mkNamedAPI @"list-conversations" (callsFed (exposeAnnotations listConversations)) <@> mkNamedAPI @"get-conversation-by-reusable-code" getConversationByReusableCode <@> mkNamedAPI @"create-group-conversation@v2" (callsFed (exposeAnnotations createGroupConversationUpToV3)) <@> mkNamedAPI @"create-group-conversation@v3" (callsFed (exposeAnnotations createGroupConversationUpToV3)) + <@> mkNamedAPI @"create-group-conversation@v5" (callsFed (exposeAnnotations createGroupConversation)) <@> mkNamedAPI @"create-group-conversation" (callsFed (exposeAnnotations createGroupConversation)) <@> mkNamedAPI @"create-self-conversation@v2" createProteusSelfConversation + <@> mkNamedAPI @"create-self-conversation@v5" createProteusSelfConversation <@> mkNamedAPI @"create-self-conversation" createProteusSelfConversation + <@> mkNamedAPI @"get-mls-self-conversation@v5" getMLSSelfConversationWithError <@> mkNamedAPI @"get-mls-self-conversation" getMLSSelfConversationWithError <@> mkNamedAPI @"get-subconversation" (callsFed getSubConversation) <@> mkNamedAPI @"leave-subconversation" (callsFed leaveSubConversation) @@ -57,6 +62,7 @@ conversationAPI = <@> mkNamedAPI @"get-subconversation-group-info" (callsFed getSubConversationGroupInfo) <@> mkNamedAPI @"create-one-to-one-conversation@v2" (callsFed createOne2OneConversation) <@> mkNamedAPI @"create-one-to-one-conversation" (callsFed createOne2OneConversation) + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation <@> mkNamedAPI @"add-members-to-conversation-unqualified" (callsFed addMembersUnqualified) <@> mkNamedAPI @"add-members-to-conversation-unqualified2" (callsFed addMembersUnqualifiedV2) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 0c8d4df22fb..0e9b8b1ee4a 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -1048,7 +1048,7 @@ conversationExisted :: ) => Local UserId -> Data.Conversation -> - Sem r ConversationResponse + Sem r (ConversationResponse Conversation) conversationExisted lusr cnv = Existed <$> conversationView lusr cnv getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index e685085b0a0..2fb941c3e7b 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -77,18 +77,11 @@ createMLSSelfConversation lusr = do } meta = ncMetadata nc gid = convToGroupId . groupIdParts meta.cnvmType . fmap Conv . tUntagged . qualifyAs lusr $ cnv - -- FUTUREWORK: Stop hard-coding the cipher suite - -- - -- 'CipherSuite 1' corresponds to - -- 'MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519'. - cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 proto = ProtocolMLS ConversationMLSData { cnvmlsGroupId = gid, - cnvmlsEpoch = Epoch 0, - cnvmlsEpochTimestamp = Nothing, - cnvmlsCipherSuite = cs + cnvmlsActiveData = Nothing } retry x5 . batch $ do setType BatchLogged @@ -104,8 +97,7 @@ createMLSSelfConversation lusr = do cnvmTeam meta, cnvmMessageTimer meta, cnvmReceiptMode meta, - Just gid, - Just cs + Just gid ) (lmems, rmems) <- addMembers cnv (ncUsers nc) @@ -122,27 +114,16 @@ createMLSSelfConversation lusr = do createConversation :: Local ConvId -> NewConversation -> Client Conversation createConversation lcnv nc = do let meta = ncMetadata nc - (proto, mgid, mep, mcs) = case ncProtocol nc of - BaseProtocolProteusTag -> (ProtocolProteus, Nothing, Nothing, Nothing) + (proto, mgid) = case ncProtocol nc of + BaseProtocolProteusTag -> (ProtocolProteus, Nothing) BaseProtocolMLSTag -> let gid = convToGroupId . groupIdParts meta.cnvmType $ Conv <$> tUntagged lcnv - ep = Epoch 0 - cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 in ( ProtocolMLS ConversationMLSData { cnvmlsGroupId = gid, - cnvmlsEpoch = ep, - cnvmlsEpochTimestamp = Nothing, - cnvmlsCipherSuite = cs + cnvmlsActiveData = Nothing }, - Just gid, - Just ep, - -- FUTUREWORK: Make the cipher suite be a record field in - -- 'NewConversation' instead of hard-coding it here. - -- - -- 'CipherSuite 1' corresponds to - -- 'MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519'. - Just cs + Just gid ) retry x5 . batch $ do setType BatchLogged @@ -159,9 +140,7 @@ createConversation lcnv nc = do cnvmMessageTimer meta, cnvmReceiptMode meta, baseProtocolToProtocol (ncProtocol nc), - mgid, - mep, - mcs + mgid ) for_ (cnvmTeam meta) $ \tid -> addPrepQuery Cql.insertTeamConv (tid, tUnqualified lcnv) (lmems, rmems) <- addMembers (tUnqualified lcnv) (ncUsers nc) @@ -355,15 +334,12 @@ toConversationMLSData :: Maybe GroupId -> Maybe Epoch -> Maybe UTCTime -> Maybe toConversationMLSData mgid mepoch mtimestamp mcs = ConversationMLSData <$> mgid - -- If there is no epoch in the database, assume the epoch is 0 - <*> (mepoch <|> Just (Epoch 0)) - <*> pure (mepoch `toTimestamp` mtimestamp) - <*> mcs - where - toTimestamp :: Maybe Epoch -> Maybe UTCTime -> Maybe UTCTime - toTimestamp Nothing _ = Nothing - toTimestamp (Just (Epoch 0)) _ = Nothing - toTimestamp (Just _) ts = ts + <*> pure + ( ActiveMLSConversationData + <$> mepoch + <*> mtimestamp + <*> mcs + ) toConv :: ConvId -> diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index ef6e26f5a4a..588053ada63 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -240,8 +240,8 @@ selectReceiptMode = "select receipt_mode from conversation where conv = ?" isConvDeleted :: PrepQuery R (Identity ConvId) (Identity (Maybe Bool)) isConvDeleted = "select deleted from conversation where conv = ?" -insertConv :: PrepQuery W (ConvId, ConvType, Maybe UserId, C.Set Access, C.Set AccessRole, Maybe Text, Maybe TeamId, Maybe Milliseconds, Maybe ReceiptMode, ProtocolTag, Maybe GroupId, Maybe Epoch, Maybe CipherSuiteTag) () -insertConv = "insert into conversation (conv, type, creator, access, access_roles_v2, name, team, message_timer, receipt_mode, protocol, group_id, epoch, cipher_suite) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" +insertConv :: PrepQuery W (ConvId, ConvType, Maybe UserId, C.Set Access, C.Set AccessRole, Maybe Text, Maybe TeamId, Maybe Milliseconds, Maybe ReceiptMode, ProtocolTag, Maybe GroupId) () +insertConv = "insert into conversation (conv, type, creator, access, access_roles_v2, name, team, message_timer, receipt_mode, protocol, group_id) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" insertMLSSelfConv :: PrepQuery @@ -255,18 +255,17 @@ insertMLSSelfConv :: Maybe TeamId, Maybe Milliseconds, Maybe ReceiptMode, - Maybe GroupId, - Maybe CipherSuiteTag + Maybe GroupId ) () insertMLSSelfConv = fromString $ "insert into conversation (conv, type, creator, access, \ \ access_roles_v2, name, team, message_timer, receipt_mode,\ - \ protocol, group_id, cipher_suite) values \ + \ protocol, group_id) values \ \ (?, ?, ?, ?, ?, ?, ?, ?, ?, " <> show (fromEnum ProtocolMLSTag) - <> ", ?, ?)" + <> ", ?)" updateToMixedConv :: PrepQuery W (ConvId, ProtocolTag, GroupId, Epoch, CipherSuiteTag) () updateToMixedConv = @@ -344,8 +343,8 @@ deleteUserConv = "delete from user where user = ? and conv = ?" selectSubConversation :: PrepQuery R (ConvId, SubConvId) (Maybe CipherSuiteTag, Maybe Epoch, Maybe (Writetime Epoch), Maybe GroupId) selectSubConversation = "SELECT cipher_suite, epoch, WRITETIME(epoch), group_id FROM subconversation WHERE conv_id = ? and subconv_id = ?" -insertSubConversation :: PrepQuery W (ConvId, SubConvId, CipherSuiteTag, Epoch, GroupId, Maybe GroupInfoData) () -insertSubConversation = "INSERT INTO subconversation (conv_id, subconv_id, cipher_suite, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?, ?)" +insertSubConversation :: PrepQuery W (ConvId, SubConvId, Epoch, GroupId, Maybe GroupInfoData) () +insertSubConversation = "INSERT INTO subconversation (conv_id, subconv_id, epoch, group_id, public_group_state) VALUES (?, ?, ?, ?, ?)" updateSubConvGroupInfo :: PrepQuery W (ConvId, SubConvId, Maybe GroupInfoData) () updateSubConvGroupInfo = "INSERT INTO subconversation (conv_id, subconv_id, public_group_state) VALUES (?, ?, ?)" diff --git a/services/galley/src/Galley/Cassandra/SubConversation.hs b/services/galley/src/Galley/Cassandra/SubConversation.hs index 4a00cf0a29e..4d775d02b99 100644 --- a/services/galley/src/Galley/Cassandra/SubConversation.hs +++ b/services/galley/src/Galley/Cassandra/SubConversation.hs @@ -26,7 +26,6 @@ import Control.Error.Util import Control.Monad.Trans.Maybe import Data.Id import Data.Map qualified as Map -import Data.Time.Clock import Galley.API.MLS.Types import Galley.Cassandra.Conversation.MLS import Galley.Cassandra.Queries qualified as Cql @@ -48,9 +47,11 @@ selectSubConversation convId subConvId = runMaybeT $ do (mSuite, mEpoch, mEpochWritetime, mGroupId) <- MaybeT $ retry x5 (query1 Cql.selectSubConversation (params LocalQuorum (convId, subConvId))) - suite <- hoistMaybe mSuite - epoch <- hoistMaybe mEpoch - epochWritetime <- hoistMaybe mEpochWritetime + let activeData = + ActiveMLSConversationData + <$> mEpoch + <*> fmap writetimeToUTC mEpochWritetime + <*> mSuite groupId <- hoistMaybe mGroupId (cm, im) <- lift $ lookupMLSClientLeafIndices groupId pure $ @@ -60,9 +61,7 @@ selectSubConversation convId subConvId = runMaybeT $ do scMLSData = ConversationMLSData { cnvmlsGroupId = groupId, - cnvmlsEpoch = epoch, - cnvmlsEpochTimestamp = epochTimestamp epoch epochWritetime, - cnvmlsCipherSuite = suite + cnvmlsActiveData = activeData }, scMembers = cm, scIndexMap = im @@ -71,20 +70,19 @@ selectSubConversation convId subConvId = runMaybeT $ do insertSubConversation :: ConvId -> SubConvId -> - CipherSuiteTag -> GroupId -> Client SubConversation -insertSubConversation convId subConvId suite groupId = do +insertSubConversation convId subConvId groupId = do retry x5 ( write Cql.insertSubConversation ( params LocalQuorum - (convId, subConvId, suite, Epoch 0, groupId, Nothing) + (convId, subConvId, Epoch 0, groupId, Nothing) ) ) - pure (newSubConversation convId subConvId suite groupId) + pure (newSubConversation convId subConvId groupId) updateSubConvGroupInfo :: ConvId -> SubConvId -> Maybe GroupInfoData -> Client () updateSubConvGroupInfo convId subConvId mGroupInfo = @@ -115,13 +113,21 @@ listSubConversations cid = do subs <- retry x1 (query Cql.listSubConversations (params LocalQuorum (Identity cid))) pure . Map.fromList $ do (subId, cs, epoch, ts, gid) <- subs + let activeData = case (epoch, ts) of + (Epoch 0, _) -> Nothing + (_, Writetime t) -> + Just + ActiveMLSConversationData + { epoch = epoch, + epochTimestamp = t, + ciphersuite = cs + } + pure ( subId, ConversationMLSData { cnvmlsGroupId = gid, - cnvmlsEpoch = epoch, - cnvmlsEpochTimestamp = epochTimestamp epoch ts, - cnvmlsCipherSuite = cs + cnvmlsActiveData = activeData } ) @@ -133,9 +139,9 @@ interpretSubConversationStoreToCassandra :: Sem (SubConversationStore ': r) a -> Sem r a interpretSubConversationStoreToCassandra = interpret $ \case - CreateSubConversation convId subConvId suite groupId -> do + CreateSubConversation convId subConvId groupId -> do logEffect "SubConversationStore.CreateSubConversation" - embedClient (insertSubConversation convId subConvId suite groupId) + embedClient (insertSubConversation convId subConvId groupId) GetSubConversation convId subConvId -> do logEffect "SubConversationStore.GetSubConversation" embedClient (selectSubConversation convId subConvId) @@ -160,10 +166,3 @@ interpretSubConversationStoreToCassandra = interpret $ \case DeleteSubConversation convId subConvId -> do logEffect "SubConversationStore.DeleteSubConversation" embedClient (deleteSubConversation convId subConvId) - --------------------------------------------------------------------------------- --- Utilities - -epochTimestamp :: Epoch -> Writetime Epoch -> Maybe UTCTime -epochTimestamp (Epoch 0) _ = Nothing -epochTimestamp _ (Writetime t) = Just t diff --git a/services/galley/src/Galley/Effects/SubConversationStore.hs b/services/galley/src/Galley/Effects/SubConversationStore.hs index 2179781b134..cc25e5ac4a2 100644 --- a/services/galley/src/Galley/Effects/SubConversationStore.hs +++ b/services/galley/src/Galley/Effects/SubConversationStore.hs @@ -30,7 +30,7 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation data SubConversationStore m a where - CreateSubConversation :: ConvId -> SubConvId -> CipherSuiteTag -> GroupId -> SubConversationStore m SubConversation + CreateSubConversation :: ConvId -> SubConvId -> GroupId -> SubConversationStore m SubConversation GetSubConversation :: ConvId -> SubConvId -> SubConversationStore m (Maybe SubConversation) GetSubConversationGroupInfo :: ConvId -> SubConvId -> SubConversationStore m (Maybe GroupInfoData) GetSubConversationEpoch :: ConvId -> SubConvId -> SubConversationStore m (Maybe Epoch) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 9c61172ec0c..dcb01c32c56 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -57,7 +57,6 @@ import Wire.API.Conversation.Role import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API.Galley -import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation @@ -1868,7 +1867,7 @@ testAddClientSubConvFailure = do assertEqual "The subconversation epoch has moved beyond 1" (Epoch 1) - (pscEpoch finalSub) + (fromJust (pscActiveData finalSub)).epoch -- FUTUREWORK: implement the following test @@ -1969,9 +1968,7 @@ testGetRemoteSubConv isAMember = do { pscParentConvId = qconv, pscSubConvId = sconv, pscGroupId = GroupId "deadbeef", - pscEpoch = Epoch 0, - pscEpochTimestamp = Nothing, - pscCipherSuite = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519, + pscActiveData = Nothing, pscMembers = [] } let mock = do @@ -2073,7 +2070,8 @@ testJoinDeletedSubConvWithRemoval = do responseJsonError =<< getSubConv (qUnqualified bob) qcnv subConvId Date: Mon, 29 Apr 2024 15:26:48 +0200 Subject: [PATCH 02/30] [chore] don't use treeefmt for hlint, readd the remove hlint rules (#4028) --- Makefile | 26 +++++++++++++++++++++++++- treefmt.toml | 5 ----- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 3d83ba04244..5791fd46ac6 100644 --- a/Makefile +++ b/Makefile @@ -154,7 +154,31 @@ ghcid: # Used by CI .PHONY: lint-all -lint-all: treefmt-check check-local-nix-derivations +lint-all: treefmt-check check-local-nix-derivations hlint-check-all + +.PHONY: hlint-check-all +hlint-check-all: + ./tools/hlint.sh -f all -m check + +.PHONY: hlint-inplace-all +hlint-inplace-all: + ./tools/hlint.sh -f all -m inplace + +.PHONY: hlint-check-pr +hlint-check-pr: + ./tools/hlint.sh -f pr -m check + +.PHONY: hlint-inplace-pr +hlint-inplace-pr: + ./tools/hlint.sh -f pr -m inplace + +.PHONY: hlint-check +hlint-check: + ./tools/hlint.sh -f changeset -m check + +.PHONY: hlint-inplace +hlint-inplace: + ./tools/hlint.sh -f changeset -m inplace .PHONY: hlint-inplace-all hlint-inplace-all: diff --git a/treefmt.toml b/treefmt.toml index 8c952fb7e6b..dce24e184d6 100644 --- a/treefmt.toml +++ b/treefmt.toml @@ -18,11 +18,6 @@ options = [ "--check-idempotence", ] -[formatter.hlint] -command = "hlint" -includes = ["*.hs"] -excludes = [ "dist*" ] - [formatter.shellcheck] command = "shellcheck" includes = ["*.sh"] From f0a91f174db18f5850c4effbdf73000b426907fb Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 29 Apr 2024 15:46:49 +0200 Subject: [PATCH 03/30] Fix openssl example in docs (#4026) --- docs/src/developer/reference/config-options.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index e6536ad8a81..fc137633541 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -39,7 +39,7 @@ openssl genpkey -algorithm ed25519 ECDSA private keys can be generated with: ``` -openssl genpkey -algorithm ec -genparam dsa -pkeyopt ec_paramgen_curve:P-256 +openssl genpkey -algorithm ec -pkeyopt ec_paramgen_curve:P-256 ``` and similar (replace `P-256` with `P-384` or `P-521`). From 4c82fd61f6c23a2535065a43f0cf3f0d919d8fbb Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 30 Apr 2024 09:38:23 +0200 Subject: [PATCH 04/30] Finish galley servantification (#4018) * Servantify get-team-members * Servantify get-team-id * Servantify test-get-clients * Servantify test-add-client * Servantify test-delete-clients * Servantify add-service * Servantify delete-service * Servantify add-bot * Servantify delete-bot * Servantify put-custom-backend * Servantify delete-custom-backend * Servantify get-bot-conversation * Remove wai-routing from galley * Remove WaiRoutes effect from galley * Add CHANGELOG entry * Update nix packages * Refactor getClients * Add fallback endpoint for compatibility Removing wai-routing's Raw endpoint in galley's servant tree changes the error responses for endpoints with recoverable failures (i.e. `Fail` route results in Servant). This commit restores compatibility by adding a fallback endpoint that always responds with 404. --- .../5-internal/servantify-galley-internal | 1 + libs/galley-types/galley-types.cabal | 2 - .../Types => wire-api/src/Wire/API}/Bot.hs | 56 ++--- .../src/Wire/API}/Bot/Service.hs | 37 ++- .../src/Wire/API/Routes/Internal/Galley.hs | 218 ++++++++++++++---- .../src/Wire/API/Routes/Public/Galley/Bot.hs | 14 ++ libs/wire-api/wire-api.cabal | 2 + services/brig/src/Brig/Provider/RPC.hs | 6 +- services/galley/default.nix | 7 - services/galley/galley.cabal | 9 - services/galley/src/Galley/API.hs | 34 --- services/galley/src/Galley/API/Clients.hs | 46 +--- .../galley/src/Galley/API/CustomBackend.hs | 28 --- services/galley/src/Galley/API/Internal.hs | 80 ++----- services/galley/src/Galley/API/Message.hs | 6 +- services/galley/src/Galley/API/Public.hs | 116 ---------- services/galley/src/Galley/API/Public/Bot.hs | 38 ++- services/galley/src/Galley/API/Query.hs | 22 +- services/galley/src/Galley/API/Teams.hs | 22 +- services/galley/src/Galley/API/Update.hs | 82 +------ services/galley/src/Galley/API/Util.hs | 17 +- services/galley/src/Galley/App.hs | 2 - .../galley/src/Galley/Cassandra/Instances.hs | 2 +- .../galley/src/Galley/Cassandra/Services.hs | 2 +- services/galley/src/Galley/Effects.hs | 3 - .../galley/src/Galley/Effects/ServiceStore.hs | 2 +- .../galley/src/Galley/Effects/WaiRoutes.hs | 40 ---- .../galley/src/Galley/Effects/WaiRoutes/IO.hs | 41 ---- services/galley/src/Galley/External.hs | 2 +- services/galley/src/Galley/Run.hs | 36 ++- services/galley/test/integration/Run.hs | 12 +- 31 files changed, 346 insertions(+), 639 deletions(-) create mode 100644 changelog.d/5-internal/servantify-galley-internal rename libs/{galley-types/src/Galley/Types => wire-api/src/Wire/API}/Bot.hs (69%) rename libs/{galley-types/src/Galley/Types => wire-api/src/Wire/API}/Bot/Service.hs (74%) delete mode 100644 services/galley/src/Galley/API.hs delete mode 100644 services/galley/src/Galley/API/Public.hs delete mode 100644 services/galley/src/Galley/Effects/WaiRoutes.hs delete mode 100644 services/galley/src/Galley/Effects/WaiRoutes/IO.hs diff --git a/changelog.d/5-internal/servantify-galley-internal b/changelog.d/5-internal/servantify-galley-internal new file mode 100644 index 00000000000..a5fb9fed313 --- /dev/null +++ b/changelog.d/5-internal/servantify-galley-internal @@ -0,0 +1 @@ +Finish servantifying galley and remove wai-routing dependency diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 4953776a8ae..04201486276 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -14,8 +14,6 @@ library -- cabal-fmt: expand src exposed-modules: Galley.Types - Galley.Types.Bot - Galley.Types.Bot.Service Galley.Types.Conversations.Members Galley.Types.Conversations.One2One Galley.Types.Conversations.Roles diff --git a/libs/galley-types/src/Galley/Types/Bot.hs b/libs/wire-api/src/Wire/API/Bot.hs similarity index 69% rename from libs/galley-types/src/Galley/Types/Bot.hs rename to libs/wire-api/src/Wire/API/Bot.hs index 94837ee81e4..6c82112f721 100644 --- a/libs/galley-types/src/Galley/Types/Bot.hs +++ b/libs/wire-api/src/Wire/API/Bot.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. @@ -18,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Types.Bot +module Wire.API.Bot ( AddBot, addBot, addBotService, @@ -33,8 +32,10 @@ module Galley.Types.Bot where import Control.Lens (makeLenses) -import Data.Aeson +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Id +import Data.OpenApi qualified as S +import Data.Schema import Imports import Wire.API.Provider.Service (ServiceRef) @@ -46,28 +47,19 @@ data AddBot = AddBot _addBotId :: !BotId, _addBotClient :: !ClientId } - -makeLenses ''AddBot + deriving (FromJSON, ToJSON, S.ToSchema) via Schema AddBot addBot :: ServiceRef -> ConvId -> BotId -> ClientId -> AddBot addBot = AddBot -instance FromJSON AddBot where - parseJSON = withObject "AddBot" $ \o -> - AddBot - <$> o .: "service" - <*> o .: "conversation" - <*> o .: "bot" - <*> o .: "client" - -instance ToJSON AddBot where - toJSON a = - object - [ "service" .= _addBotService a, - "conversation" .= _addBotConv a, - "bot" .= _addBotId a, - "client" .= _addBotClient a - ] +instance ToSchema AddBot where + schema = + object "AddBot" $ + AddBot + <$> _addBotService .= field "service" schema + <*> _addBotConv .= field "conversation" schema + <*> _addBotId .= field "bot" schema + <*> _addBotClient .= field "client" schema -- RemoveBot ------------------------------------------------------------------ @@ -75,21 +67,17 @@ data RemoveBot = RemoveBot { _rmBotConv :: !ConvId, _rmBotId :: !BotId } - -makeLenses ''RemoveBot + deriving (FromJSON, ToJSON, S.ToSchema) via Schema RemoveBot removeBot :: ConvId -> BotId -> RemoveBot removeBot = RemoveBot -instance FromJSON RemoveBot where - parseJSON = withObject "RemoveBot" $ \o -> - RemoveBot - <$> o .: "conversation" - <*> o .: "bot" +instance ToSchema RemoveBot where + schema = + object "RemoveBot" $ + RemoveBot + <$> _rmBotConv .= field "conversation" schema + <*> _rmBotId .= field "bot" schema -instance ToJSON RemoveBot where - toJSON a = - object - [ "conversation" .= _rmBotConv a, - "bot" .= _rmBotId a - ] +makeLenses ''AddBot +makeLenses ''RemoveBot diff --git a/libs/galley-types/src/Galley/Types/Bot/Service.hs b/libs/wire-api/src/Wire/API/Bot/Service.hs similarity index 74% rename from libs/galley-types/src/Galley/Types/Bot/Service.hs rename to libs/wire-api/src/Wire/API/Bot/Service.hs index 30d969dd739..05554f34da6 100644 --- a/libs/galley-types/src/Galley/Types/Bot/Service.hs +++ b/libs/wire-api/src/Wire/API/Bot/Service.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. @@ -18,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Types.Bot.Service +module Wire.API.Bot.Service ( Service (..), newService, serviceRef, @@ -30,8 +29,10 @@ module Galley.Types.Bot.Service where import Control.Lens (makeLenses) -import Data.Aeson +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Misc (Fingerprint, HttpsUrl, Rsa) +import Data.OpenApi qualified as S +import Data.Schema import Imports import Wire.API.Provider.Service hiding (Service (..)) @@ -45,27 +46,19 @@ data Service = Service _serviceFingerprints :: ![Fingerprint Rsa], _serviceEnabled :: !Bool } - -makeLenses ''Service + deriving (FromJSON, ToJSON, S.ToSchema) via Schema Service newService :: ServiceRef -> HttpsUrl -> ServiceToken -> [Fingerprint Rsa] -> Service newService ref url tok fps = Service ref url tok fps True -instance FromJSON Service where - parseJSON = withObject "Service" $ \o -> - Service - <$> o .: "ref" - <*> o .: "base_url" - <*> o .: "auth_token" - <*> o .: "fingerprints" - <*> o .: "enabled" +instance ToSchema Service where + schema = + object "BotService" $ + Service + <$> _serviceRef .= field "ref" schema + <*> _serviceUrl .= field "base_url" schema + <*> _serviceToken .= field "auth_token" schema + <*> _serviceFingerprints .= field "fingerprints" (array schema) + <*> _serviceEnabled .= field "enabled" schema -instance ToJSON Service where - toJSON s = - object - [ "ref" .= _serviceRef s, - "base_url" .= _serviceUrl s, - "auth_token" .= _serviceToken s, - "fingerprints" .= _serviceFingerprints s, - "enabled" .= _serviceEnabled s - ] +makeLenses ''Service diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index c68dc51a76b..ff4c884ce42 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -18,22 +18,26 @@ module Wire.API.Routes.Internal.Galley where import Control.Lens ((.~)) +import Data.Domain import Data.Id as Id import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) import Imports hiding (head) -import Servant hiding (JSON, WithStatus) -import Servant qualified hiding (WithStatus) +import Servant hiding (WithStatus) import Servant.OpenApi import Wire.API.ApplyMods +import Wire.API.Bot +import Wire.API.Bot.Service import Wire.API.Conversation import Wire.API.Conversation.Role +import Wire.API.CustomBackend import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.FederationStatus import Wire.API.MakesFederatedCall +import Wire.API.Provider.Service (ServiceRef) import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti import Wire.API.Routes.Internal.Galley.TeamsIntra @@ -42,6 +46,7 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public import Wire.API.Routes.Public.Galley.Conversation import Wire.API.Routes.Public.Galley.Feature +import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture import Wire.API.Routes.Version import Wire.API.Team @@ -186,7 +191,7 @@ type IFeatureAPI = ] "user_id" UserId - :> Get '[Servant.JSON] AllFeatureConfigs + :> Get '[JSON] AllFeatureConfigs ) type InternalAPI = "i" :> InternalAPIBase @@ -194,7 +199,7 @@ type InternalAPI = "i" :> InternalAPIBase type InternalAPIBase = Named "status" - ( "status" :> MultiVerb 'GET '[Servant.JSON] '[RespondEmpty 200 "OK"] () + ( "status" :> MultiVerb 'GET '[JSON] '[RespondEmpty 200 "OK"] () ) -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in @@ -207,7 +212,7 @@ type InternalAPIBase = :> ZLocalUser :> ZOptConn :> "user" - :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] () + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Remove a user from Galley"] () ) -- This endpoint can lead to the following events being sent: -- - ConvCreate event to self, if conversation did not exist before @@ -226,7 +231,7 @@ type InternalAPIBase = :> ZOptConn :> "conversations" :> "connect" - :> ReqBody '[Servant.JSON] Connect + :> ReqBody '[JSON] Connect :> ConversationVerb 'V6 Conversation ) -- This endpoint is meant for testing membership of a conversation @@ -238,7 +243,7 @@ type InternalAPIBase = :> Capture "gid" GroupId :> MultiVerb1 'GET - '[Servant.JSON] + '[JSON] (Respond 200 "Clients" ClientList) ) :<|> Named @@ -246,19 +251,20 @@ type InternalAPIBase = ( "guard-legalhold-policy-conflicts" :> CanThrow 'MissingLegalholdConsent :> CanThrow 'MissingLegalholdConsentOldClients - :> ReqBody '[Servant.JSON] GuardLegalholdPolicyConflicts - :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "Guard Legalhold Policy") + :> ReqBody '[JSON] GuardLegalholdPolicyConflicts + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "Guard Legalhold Policy") ) :<|> ILegalholdWhitelistedTeamsAPI :<|> ITeamsAPI + :<|> IMiscAPI :<|> Named "upsert-one2one" ( Summary "Create or Update a connect or one2one conversation." :> "conversations" :> "one2one" :> "upsert" - :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest - :> MultiVerb1 'POST '[Servant.JSON] (RespondEmpty 200 "Upsert One2One Policy") + :> ReqBody '[JSON] UpsertOne2OneConversationRequest + :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Upsert One2One Policy") ) :<|> IFeatureAPI :<|> IFederationAPI @@ -273,15 +279,15 @@ type ILegalholdWhitelistedTeamsAPI = type ILegalholdWhitelistedTeamsAPIBase = Named "set-team-legalhold-whitelisted" - (MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "Team Legalhold Whitelisted")) + (MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "Team Legalhold Whitelisted")) :<|> Named "unset-team-legalhold-whitelisted" - (MultiVerb1 'DELETE '[Servant.JSON] (RespondEmpty 204 "Team Legalhold un-Whitelisted")) + (MultiVerb1 'DELETE '[JSON] (RespondEmpty 204 "Team Legalhold un-Whitelisted")) :<|> Named "get-team-legalhold-whitelisted" ( MultiVerb 'GET - '[Servant.JSON] + '[JSON] '[ RespondEmpty 404 "Team not Legalhold Whitelisted", RespondEmpty 200 "Team Legalhold Whitelisted" ] @@ -291,14 +297,14 @@ type ILegalholdWhitelistedTeamsAPIBase = type ITeamsAPI = "teams" :> Capture "tid" TeamId :> ITeamsAPIBase type ITeamsAPIBase = - Named "get-team-internal" (CanThrow 'TeamNotFound :> Get '[Servant.JSON] TeamData) + Named "get-team-internal" (CanThrow 'TeamNotFound :> Get '[JSON] TeamData) :<|> Named "create-binding-team" ( ZUser - :> ReqBody '[Servant.JSON] BindingNewTeam + :> ReqBody '[JSON] BindingNewTeam :> MultiVerb1 'PUT - '[Servant.JSON] + '[JSON] ( WithHeaders '[Header "Location" TeamId] TeamId @@ -312,16 +318,16 @@ type ITeamsAPIBase = :> CanThrow 'DeleteQueueFull :> CanThrow 'TeamNotFound :> QueryFlag "force" - :> MultiVerb1 'DELETE '[Servant.JSON] (RespondEmpty 202 "OK") + :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 202 "OK") ) - :<|> Named "get-team-name" ("name" :> CanThrow 'TeamNotFound :> Get '[Servant.JSON] TeamName) + :<|> Named "get-team-name" ("name" :> CanThrow 'TeamNotFound :> Get '[JSON] TeamName) :<|> Named "update-team-status" ( "status" :> CanThrow 'TeamNotFound :> CanThrow 'InvalidTeamStatusUpdate - :> ReqBody '[Servant.JSON] TeamStatusUpdate - :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "OK") + :> ReqBody '[JSON] TeamStatusUpdate + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "OK") ) :<|> "members" :> ( Named @@ -329,25 +335,25 @@ type ITeamsAPIBase = ( CanThrow 'TooManyTeamMembers :> CanThrow 'TooManyTeamMembersOnTeamWithLegalhold :> CanThrow 'TooManyTeamAdmins - :> ReqBody '[Servant.JSON] NewTeamMember - :> MultiVerb1 'POST '[Servant.JSON] (RespondEmpty 200 "OK") + :> ReqBody '[JSON] NewTeamMember + :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "OK") ) :<|> Named "unchecked-get-team-members" ( QueryParam' '[Strict] "maxResults" (Range 1 HardTruncationLimit Int32) - :> Get '[Servant.JSON] TeamMemberList + :> Get '[JSON] TeamMemberList ) :<|> Named "unchecked-get-team-member" ( Capture "uid" UserId :> CanThrow 'TeamMemberNotFound - :> Get '[Servant.JSON] TeamMember + :> Get '[JSON] TeamMember ) :<|> Named "can-user-join-team" ( "check" :> CanThrow 'TooManyTeamMembersOnTeamWithLegalhold - :> MultiVerb1 'GET '[Servant.JSON] (RespondEmpty 200 "User can join") + :> MultiVerb1 'GET '[JSON] (RespondEmpty 200 "User can join") ) :<|> Named "unchecked-update-team-member" @@ -358,8 +364,8 @@ type ITeamsAPIBase = :> CanThrow 'TooManyTeamAdmins :> CanThrow 'NotATeamMember :> CanThrow OperationDenied - :> ReqBody '[Servant.JSON] NewTeamMember - :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "") + :> ReqBody '[JSON] NewTeamMember + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 200 "") ) ) :<|> Named @@ -369,18 +375,18 @@ type ITeamsAPIBase = :> CanThrow 'AccessDenied :> CanThrow 'TeamMemberNotFound :> CanThrow 'NotATeamMember - :> MultiVerb1 'GET '[Servant.JSON] (RespondEmpty 200 "User is team owner") + :> MultiVerb1 'GET '[JSON] (RespondEmpty 200 "User is team owner") ) :<|> "search-visibility" - :> ( Named "get-search-visibility-internal" (Get '[Servant.JSON] TeamSearchVisibilityView) + :> ( Named "get-search-visibility-internal" (Get '[JSON] TeamSearchVisibilityView) :<|> Named "set-search-visibility-internal" ( CanThrow 'TeamSearchVisibilityNotEnabled :> CanThrow OperationDenied :> CanThrow 'NotATeamMember :> CanThrow 'TeamNotFound - :> ReqBody '[Servant.JSON] TeamSearchVisibilityView - :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 204 "OK") + :> ReqBody '[JSON] TeamSearchVisibilityView + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 204 "OK") ) ) @@ -401,8 +407,8 @@ type FeatureStatusBasePutInternal errs featureConfig = (AppendSymbol "Put config for " (FeatureSymbol featureConfig)) errs featureConfig - ( ReqBody '[Servant.JSON] (WithStatusNoLock featureConfig) - :> Put '[Servant.JSON] (WithStatus featureConfig) + ( ReqBody '[JSON] (WithStatusNoLock featureConfig) + :> Put '[JSON] (WithStatus featureConfig) ) type FeatureStatusBasePatchInternal errs featureConfig = @@ -410,8 +416,8 @@ type FeatureStatusBasePatchInternal errs featureConfig = (AppendSymbol "Patch config for " (FeatureSymbol featureConfig)) errs featureConfig - ( ReqBody '[Servant.JSON] (WithStatusPatch featureConfig) - :> Patch '[Servant.JSON] (WithStatus featureConfig) + ( ReqBody '[JSON] (WithStatusPatch featureConfig) + :> Patch '[JSON] (WithStatus featureConfig) ) type FeatureStatusBaseInternal desc errs featureConfig a = @@ -441,7 +447,7 @@ type IFeatureStatusLockStatusPutWithDesc featureName desc = :> "features" :> FeatureSymbol featureName :> Capture "lockStatus" LockStatus - :> Put '[Servant.JSON] LockStatusResponse + :> Put '[JSON] LockStatusResponse ) type FeatureNoConfigMultiGetBase featureName = @@ -449,8 +455,8 @@ type FeatureNoConfigMultiGetBase featureName = (AppendSymbol "Get team feature status in bulk for feature " (FeatureSymbol featureName)) :> "features-multi-teams" :> FeatureSymbol featureName - :> ReqBody '[Servant.JSON] TeamFeatureNoConfigMultiRequest - :> Post '[Servant.JSON] (TeamFeatureNoConfigMultiResponse featureName) + :> ReqBody '[JSON] TeamFeatureNoConfigMultiRequest + :> Post '[JSON] (TeamFeatureNoConfigMultiResponse featureName) type IFeatureNoConfigMultiGet f = Named @@ -464,8 +470,8 @@ type IFederationAPI = :> CanThrow UnreachableBackends :> ZLocalUser :> "federation-status" - :> ReqBody '[Servant.JSON] RemoteDomains - :> Get '[Servant.JSON] FederationStatus + :> ReqBody '[JSON] RemoteDomains + :> Get '[JSON] FederationStatus ) type IConversationAPI = @@ -475,7 +481,7 @@ type IConversationAPI = :> Capture "cnv" ConvId :> "members" :> Capture "usr" UserId - :> Get '[Servant.JSON] (Maybe Member) + :> Get '[JSON] (Maybe Member) ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before @@ -491,7 +497,7 @@ type IConversationAPI = :> Capture "cnv" ConvId :> "accept" :> "v2" - :> Put '[Servant.JSON] Conversation + :> Put '[JSON] Conversation ) :<|> Named "conversation-block-unqualified" @@ -501,7 +507,7 @@ type IConversationAPI = :> "conversations" :> Capture "cnv" ConvId :> "block" - :> Put '[Servant.JSON] () + :> Put '[JSON] () ) :<|> Named "conversation-block" @@ -511,7 +517,7 @@ type IConversationAPI = :> "conversations" :> QualifiedCapture "cnv" ConvId :> "block" - :> Put '[Servant.JSON] () + :> Put '[JSON] () ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before @@ -526,7 +532,7 @@ type IConversationAPI = :> "conversations" :> Capture "cnv" ConvId :> "unblock" - :> Put '[Servant.JSON] Conversation + :> Put '[JSON] Conversation ) -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before @@ -541,7 +547,7 @@ type IConversationAPI = :> "conversations" :> QualifiedCapture "cnv" ConvId :> "unblock" - :> Put '[Servant.JSON] () + :> Put '[JSON] () ) :<|> Named "conversation-meta" @@ -549,7 +555,7 @@ type IConversationAPI = :> "conversations" :> Capture "cnv" ConvId :> "meta" - :> Get '[Servant.JSON] ConversationMetadata + :> Get '[JSON] ConversationMetadata ) :<|> Named "conversation-mls-one-to-one" @@ -559,7 +565,7 @@ type IConversationAPI = :> "mls-one2one" :> ZLocalUser :> QualifiedCapture "user" UserId - :> Get '[Servant.JSON] Conversation + :> Get '[JSON] Conversation ) :<|> Named "conversation-mls-one-to-one-established" @@ -570,7 +576,119 @@ type IConversationAPI = :> "mls-one2one" :> QualifiedCapture "user" UserId :> "established" - :> Get '[Servant.JSON] Bool + :> Get '[JSON] Bool + ) + +type IMiscAPI = + Named + "get-team-members" + ( CanThrow 'NonBindingTeam + :> CanThrow 'TeamNotFound + :> "users" + :> Capture "uid" UserId + :> "team" + :> "members" + :> Get '[JSON] TeamMemberList + ) + :<|> Named + "get-team-id" + ( CanThrow 'NonBindingTeam + :> CanThrow 'TeamNotFound + :> "users" + :> Capture "uid" UserId + :> "team" + :> Get '[JSON] TeamId + ) + :<|> Named + "test-get-clients" + ( -- eg. https://github.com/wireapp/wire-server/blob/3bdca5fc8154e324773802a0deb46d884bd09143/services/brig/test/integration/API/User/Client.hs#L319 + "test" + :> "clients" + :> ZUser + :> Get '[JSON] [ClientId] + ) + :<|> Named + "test-add-client" + ( "clients" + :> ZUser + :> Capture "cid" ClientId + :> MultiVerb1 + 'POST + '[JSON] + (RespondEmpty 200 "OK") + ) + :<|> Named + "test-delete-client" + ( "clients" + :> ZUser + :> Capture "cid" ClientId + :> MultiVerb1 + 'DELETE + '[JSON] + (RespondEmpty 200 "OK") + ) + :<|> Named + "add-service" + ( "services" + :> ReqBody '[JSON] Service + :> MultiVerb1 + 'POST + '[JSON] + (RespondEmpty 200 "OK") + ) + :<|> Named + "delete-service" + ( "services" + :> ReqBody '[JSON] ServiceRef + :> MultiVerb1 + 'DELETE + '[JSON] + (RespondEmpty 200 "OK") + ) + :<|> Named + "add-bot" + ( -- This endpoint can lead to the following events being sent: + -- - MemberJoin event to members + CanThrow ('ActionDenied 'AddConversationMember) + :> CanThrow 'ConvNotFound + :> CanThrow 'InvalidOperation + :> CanThrow 'TooManyMembers + :> "bots" + :> ZLocalUser + :> ZConn + :> ReqBody '[JSON] AddBot + :> Post '[JSON] Event + ) + :<|> Named + "delete-bot" + ( -- This endpoint can lead to the following events being sent: + -- - MemberLeave event to members + CanThrow 'ConvNotFound + :> CanThrow ('ActionDenied 'RemoveConversationMember) + :> "bots" + :> ZLocalUser + :> ZOptConn + :> ReqBody '[JSON] RemoveBot + :> MultiVerb + 'DELETE + '[JSON] + (UpdateResponses "Bot not found" "Bot deleted" Event) + (UpdateResult Event) + ) + :<|> Named + "put-custom-backend" + ( "custom-backend" + :> "by-domain" + :> Capture "domain" Domain + :> ReqBody '[JSON] CustomBackend + :> MultiVerb1 'PUT '[JSON] (RespondEmpty 201 "OK") + ) + :<|> Named + "delete-custom-backend" + ( "custom-backend" + :> "by-domain" + :> Capture "domain" Domain + :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 200 "OK") ) swaggerDoc :: OpenApi diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs index 3eb711a96c8..6d4359b545c 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs @@ -23,6 +23,7 @@ import Wire.API.Error import Wire.API.Error.Galley import Wire.API.MakesFederatedCall import Wire.API.Message +import Wire.API.Provider.Bot import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.Routes.Public @@ -47,3 +48,16 @@ type BotAPI = (PostOtrResponses ClientMismatch) (PostOtrResponse ClientMismatch) ) + :<|> Named + "get-bot-conversation" + ( CanThrow 'AccessDenied + :> CanThrow 'ConvNotFound + :> CanThrow OperationDenied + :> CanThrow 'NotATeamMember + :> CanThrow 'TeamNotFound + :> "bot" + :> "conversation" + :> ZBot + :> ZConversation + :> Get '[JSON] BotConvView + ) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b34eb3a5e22..3ea6d980ab9 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -69,6 +69,8 @@ library exposed-modules: Wire.API.ApplyMods Wire.API.Asset + Wire.API.Bot + Wire.API.Bot.Service Wire.API.Call.Config Wire.API.Connection Wire.API.ConverProtoLens diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index d11dc336a8c..98670483b73 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -42,9 +42,6 @@ import Data.Aeson import Data.ByteString.Conversion import Data.Id import Data.List1 qualified as List1 -import Galley.Types.Bot qualified as Galley -import Galley.Types.Bot.Service (serviceEnabled) -import Galley.Types.Bot.Service qualified as Galley import Imports import Network.HTTP.Client qualified as Http import Network.HTTP.Types.Method @@ -53,6 +50,9 @@ import Ssl.Util (withVerifiedSslConnection) import System.Logger.Class (MonadLogger, field, msg, val, (~~)) import System.Logger.Class qualified as Log import URI.ByteString +import Wire.API.Bot qualified as Galley +import Wire.API.Bot.Service (serviceEnabled) +import Wire.API.Bot.Service qualified as Galley import Wire.API.Event.Conversation qualified as Conv import Wire.API.Provider (httpsUrl) import Wire.API.Provider.External diff --git a/services/galley/default.nix b/services/galley/default.nix index 7148f3c23b4..7985313dc72 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -118,8 +118,6 @@ , wai , wai-extra , wai-middleware-gunzip -, wai-predicates -, wai-routing , wai-utilities , warp , warp-tls @@ -151,7 +149,6 @@ mkDerivation { case-insensitive cassandra-util cassava - cereal comonad containers cql @@ -184,7 +181,6 @@ mkDerivation { polysemy polysemy-wire-zoo proto-lens - protobuf raw-strings-qq resourcet retry @@ -215,8 +211,6 @@ mkDerivation { wai wai-extra wai-middleware-gunzip - wai-predicates - wai-routing wai-utilities wire-api wire-api-federation @@ -264,7 +258,6 @@ mkDerivation { lens lens-aeson memory - metrics-wai mtl network network-uri diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 7197ea7ce6e..2c51515dbdb 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -72,7 +72,6 @@ library -- cabal-fmt: expand src exposed-modules: - Galley.API Galley.API.Action Galley.API.Clients Galley.API.Create @@ -106,7 +105,6 @@ library Galley.API.MLS.Util Galley.API.MLS.Welcome Galley.API.One2One - Galley.API.Public Galley.API.Public.Bot Galley.API.Public.Conversation Galley.API.Public.CustomBackend @@ -181,8 +179,6 @@ library Galley.Effects.TeamMemberStore Galley.Effects.TeamNotificationStore Galley.Effects.TeamStore - Galley.Effects.WaiRoutes - Galley.Effects.WaiRoutes.IO Galley.Env Galley.External Galley.External.LegalHoldService @@ -300,7 +296,6 @@ library , case-insensitive , cassandra-util >=0.16.2 , cassava >=0.5.2 - , cereal >=0.4 , comonad , containers >=0.5 , cql @@ -333,7 +328,6 @@ library , polysemy , polysemy-wire-zoo , proto-lens >=0.2 - , protobuf >=0.2 , raw-strings-qq >=1.0 , resourcet >=1.1 , retry >=0.5 @@ -364,8 +358,6 @@ library , wai >=3.0 , wai-extra >=3.0 , wai-middleware-gunzip >=0.0.2 - , wai-predicates >=0.8 - , wai-routing >=0.12 , wai-utilities >=0.16 , wire-api , wire-api-federation @@ -508,7 +500,6 @@ executable galley-integration , lens , lens-aeson , memory - , metrics-wai , mtl , network , network-uri diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs deleted file mode 100644 index 487115e067f..00000000000 --- a/services/galley/src/Galley/API.hs +++ /dev/null @@ -1,34 +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 . - -module Galley.API - ( waiSitemap, - servantSitemap, - ) -where - -import Galley.API.Internal -import Galley.API.Public qualified as Public -import Galley.API.Public.Servant -import Galley.App (GalleyEffects) -import Network.Wai.Routing (Routes) -import Polysemy - -waiSitemap :: Routes () (Sem GalleyEffects) () -waiSitemap = do - Public.sitemap - waiInternalSitemap diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index a45fa6f607b..8bd23185dd9 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -16,9 +16,8 @@ -- with this program. If not, see . module Galley.API.Clients - ( getClientsH, - addClientH, - rmClientH, + ( getClients, + rmClient, ) where @@ -33,16 +32,12 @@ import Galley.API.Query qualified as Query import Galley.API.Util import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess -import Galley.Effects.BrigAccess qualified as E import Galley.Effects.ClientStore qualified as E import Galley.Effects.ConversationStore (getConversation) import Galley.Env -import Galley.Types.Clients (clientIds, fromUserClients) +import Galley.Types.Clients (clientIds) import Imports import Network.AMQP qualified as Q -import Network.Wai -import Network.Wai.Predicate hiding (Error, setStatus) -import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Input @@ -56,41 +51,18 @@ import Wire.API.Routes.MultiTablePaging import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (CassandraPaging) -getClientsH :: - ( Member BrigAccess r, - Member ClientStore r - ) => - UserId -> - Sem r Response -getClientsH usr = do - json <$> getClients usr - getClients :: ( Member BrigAccess r, Member ClientStore r ) => UserId -> Sem r [ClientId] -getClients usr = do - isInternal <- E.useIntraClientListing - clts <- - if isInternal - then fromUserClients <$> E.lookupClients [usr] - else E.getClients [usr] - pure (clientIds usr clts) - -addClientH :: - Member ClientStore r => - UserId ::: ClientId -> - Sem r Response -addClientH (usr ::: clt) = do - E.createClient usr clt - pure empty +getClients usr = clientIds usr <$> getBrigClients [usr] -- | Remove a client from conversations it is part of according to the -- conversation protocol (Proteus or MLS). In addition, remove the client from -- the "clients" table in Galley. -rmClientH :: +rmClient :: forall p1 r. ( p1 ~ CassandraPaging, Member ClientStore r, @@ -111,9 +83,10 @@ rmClientH :: Member SubConversationStore r, Member P.TinyLog r ) => - UserId ::: ClientId -> - Sem r Response -rmClientH (usr ::: cid) = do + UserId -> + ClientId -> + Sem r () +rmClient usr cid = do clients <- E.getClients [usr] if (cid `elem` clientIds usr clients) then do @@ -128,7 +101,6 @@ rmClientH (usr ::: cid) = do . field "client" (clientToText cid) . msg (val "rmClientH: client already gone") ) - pure empty where goConvs :: Range 1 1000 Int32 -> ConvIdsPage -> Local UserId -> Sem r () goConvs range page lusr = do diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 0d772520910..1e82482a22b 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -18,22 +18,13 @@ -- | See also: 'DomainsBlockedForRegistration'. module Galley.API.CustomBackend ( getCustomBackendByDomain, - internalPutCustomBackendByDomainH, - internalDeleteCustomBackendByDomainH, ) where import Data.Domain (Domain) -import Galley.API.Util import Galley.Effects.CustomBackendStore -import Galley.Effects.WaiRoutes import Imports hiding ((\\)) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Predicate hiding (Error, setStatus) -import Network.Wai.Utilities hiding (Error) import Polysemy -import Wire.API.CustomBackend import Wire.API.CustomBackend qualified as Public import Wire.API.Error import Wire.API.Error.Galley @@ -50,22 +41,3 @@ getCustomBackendByDomain domain = getCustomBackend domain >>= \case Nothing -> throwS @'CustomBackendNotFound Just customBackend -> pure customBackend - --- INTERNAL ------------------------------------------------------------------- - -internalPutCustomBackendByDomainH :: - ( Member CustomBackendStore r, - Member WaiRoutes r - ) => - Domain ::: JsonRequest CustomBackend -> - Sem r Response -internalPutCustomBackendByDomainH (domain ::: req) = do - customBackend <- fromJsonBody req - -- simple enough to not need a separate function - setCustomBackend domain customBackend - pure (empty & setStatus status201) - -internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Sem r Response -internalDeleteCustomBackendByDomainH (domain ::: _) = do - deleteCustomBackend domain - pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 0236f5f23dc..27177595cac 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -16,8 +16,7 @@ -- with this program. If not, see . module Galley.API.Internal - ( waiInternalSitemap, - internalAPI, + ( internalAPI, InternalAPI, deleteLoop, safeForever, @@ -37,13 +36,11 @@ import Data.Time import Galley.API.Action import Galley.API.Clients qualified as Clients import Galley.API.Create qualified as Create -import Galley.API.CustomBackend qualified as CustomBackend import Galley.API.Error import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts import Galley.API.MLS.Removal import Galley.API.One2One -import Galley.API.Public import Galley.API.Public.Servant import Galley.API.Query qualified as Query import Galley.API.Teams (uncheckedDeleteTeamMember) @@ -58,24 +55,20 @@ import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess import Galley.Effects.ClientStore import Galley.Effects.ConversationStore +import Galley.Effects.CustomBackendStore import Galley.Effects.LegalHoldStore as LegalHoldStore import Galley.Effects.MemberStore qualified as E +import Galley.Effects.ServiceStore import Galley.Effects.TeamStore import Galley.Effects.TeamStore qualified as E import Galley.Monad import Galley.Options hiding (brig) import Galley.Queue qualified as Q -import Galley.Types.Bot (AddBot, RemoveBot) -import Galley.Types.Bot.Service import Galley.Types.Conversations.Members (RemoteMember (rmId)) import Galley.Types.UserList import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding (head) import Network.AMQP qualified as Q -import Network.Wai.Predicate hiding (Error, err, result, setStatus) -import Network.Wai.Routing hiding (App, route, toList) -import Network.Wai.Utilities hiding (Error) -import Network.Wai.Utilities.ZAuth import Polysemy import Polysemy.Error import Polysemy.Input @@ -85,7 +78,6 @@ import System.Logger.Class hiding (Path, name) import System.Logger.Class qualified as Log import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Action -import Wire.API.CustomBackend import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.Conversation @@ -93,7 +85,6 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.Provider.Service hiding (Service) import Wire.API.Routes.API import Wire.API.Routes.Internal.Galley import Wire.API.Routes.Internal.Galley.TeamsIntra @@ -114,6 +105,7 @@ internalAPI = <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI <@> iTeamsAPI + <@> miscAPI <@> mkNamedAPI @"upsert-one2one" iUpsertOne2OneConversation <@> featureAPI <@> federationAPI @@ -173,6 +165,20 @@ iTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @SearchVisibilityAvailableConfig) tid) ) +miscAPI :: API IMiscAPI GalleyEffects +miscAPI = + mkNamedAPI @"get-team-members" Teams.getBindingTeamMembers + <@> mkNamedAPI @"get-team-id" lookupBindingTeam + <@> mkNamedAPI @"test-get-clients" Clients.getClients + <@> mkNamedAPI @"test-add-client" createClient + <@> mkNamedAPI @"test-delete-client" Clients.rmClient + <@> mkNamedAPI @"add-service" createService + <@> mkNamedAPI @"delete-service" deleteService + <@> mkNamedAPI @"add-bot" Update.addBot + <@> mkNamedAPI @"delete-bot" Update.rmBot + <@> mkNamedAPI @"put-custom-backend" setCustomBackend + <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend + featureAPI :: API IFeatureAPI GalleyEffects featureAPI = mkNamedAPI @'("iget", SSOConfig) (getFeatureStatus DontDoAuth) @@ -248,56 +254,6 @@ featureAPI = <@> mkNamedAPI @'("ipatch", LimitedEventFanoutConfig) patchFeatureStatusInternal <@> mkNamedAPI @"feature-configs-internal" (maybe getAllFeatureConfigsForServer getAllFeatureConfigsForUser) -waiInternalSitemap :: Routes a (Sem GalleyEffects) () -waiInternalSitemap = unsafeCallsFed @'Galley @"on-client-removed" $ unsafeCallsFed @'Galley @"on-mls-message-sent" $ do - -- Misc API (internal) ------------------------------------------------ - - get "/i/users/:uid/team/members" (continueE Teams.getBindingTeamMembersH) $ - capture "uid" - - get "/i/users/:uid/team" (continueE Teams.getBindingTeamIdH) $ - capture "uid" - - get "/i/test/clients" (continueE Clients.getClientsH) $ - zauthUserId - -- eg. https://github.com/wireapp/wire-server/blob/3bdca5fc8154e324773802a0deb46d884bd09143/services/brig/test/integration/API/User/Client.hs#L319 - - post "/i/clients/:client" (continue Clients.addClientH) $ - zauthUserId - .&. capture "client" - - delete "/i/clients/:client" (continue Clients.rmClientH) $ - zauthUserId - .&. capture "client" - - post "/i/services" (continue Update.addServiceH) $ - jsonRequest @Service - - delete "/i/services" (continue Update.rmServiceH) $ - jsonRequest @ServiceRef - - -- This endpoint can lead to the following events being sent: - -- - MemberJoin event to members - post "/i/bots" (continueE Update.addBotH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @AddBot - - -- This endpoint can lead to the following events being sent: - -- - MemberLeave event to members - delete "/i/bots" (continueE Update.rmBotH) $ - zauthUserId - .&. opt zauthConnId - .&. jsonRequest @RemoveBot - - put "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalPutCustomBackendByDomainH) $ - capture "domain" - .&. jsonRequest @CustomBackend - - delete "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalDeleteCustomBackendByDomainH) $ - capture "domain" - .&. accept "application" "json" - rmUser :: forall p1 p2 r. ( p1 ~ CassandraPaging, diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index b436ea62250..8d0d8dba25c 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -298,11 +298,7 @@ postBroadcast lusr con msg = runError $ do contacts <- getContactList senderUser let users = toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) - isInternal <- useIntraClientListing - localClients <- - if isInternal - then Clients.fromUserClients <$> lookupClients users - else getClients users + localClients <- getBrigClients users let qualifiedLocalClients = Map.mapKeys (tDomain lusr,) . makeUserMap (Set.fromList users) diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs deleted file mode 100644 index 0a3426ebe76..00000000000 --- a/services/galley/src/Galley/API/Public.hs +++ /dev/null @@ -1,116 +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 . - -module Galley.API.Public - ( sitemap, - continueE, - ) -where - -import Data.Id -import Data.Qualified -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features qualified as Features -import Galley.App -import Galley.Effects -import Galley.Effects qualified as E -import Galley.Options -import Imports hiding (head) -import Network.Wai -import Network.Wai.Predicate hiding (Error, or, result, setStatus) -import Network.Wai.Routing hiding (route) -import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) -import Polysemy -import Polysemy.Error -import Polysemy.Input -import Polysemy.Internal -import Wire.API.Conversation.Role -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Event.Team qualified as Public () -import Wire.API.Routes.API - --- These are all the errors that can be thrown by wai-routing handlers. --- We don't do any static checks on these errors, so we simply remap them to --- dynamic errors. See 'continueE'. -type ErrorEffects = - '[ ErrorS ('ActionDenied 'AddConversationMember), - ErrorS ('ActionDenied 'LeaveConversation), - ErrorS ('ActionDenied 'RemoveConversationMember), - ErrorS 'ConvNotFound, - ErrorS 'InvalidOperation, - ErrorS 'NotConnected, - ErrorS 'TeamNotFound, - ErrorS 'InvalidTeamStatusUpdate, - ErrorS 'TooManyTeamMembers, - ErrorS 'TooManyMembers, - ErrorS 'TeamMemberNotFound, - ErrorS 'AccessDenied, - ErrorS 'NotATeamMember, - ErrorS 'NonBindingTeam, - ErrorS OperationDenied, - ErrorS 'InvalidPermissions, - ErrorS 'NoAddToBinding, - ErrorS 'UserBindingExists, - ErrorS 'CustomBackendNotFound, - ErrorS 'DeleteQueueFull, - ErrorS 'NoBindingTeam, - ErrorS 'NotAOneMemberTeam, - ErrorS 'TeamSearchVisibilityNotEnabled, - ErrorS 'TooManyTeamMembersOnTeamWithLegalhold, - Error AuthenticationError - ] - --- Wrapper of 'continue' that remaps all static errors to dynamic ones. -continueE :: - forall a r. - Member (Error DynError) r => - (a -> Sem (Append ErrorEffects r) Response) -> - a -> - Continue (Sem r) -> - Sem r ResponseReceived -continueE h = continue (interpretServerEffects @ErrorEffects . h) - -sitemap :: Routes () (Sem GalleyEffects) () -sitemap = do - -- Bot API ------------------------------------------------------------ - - get "/bot/conversation" (continueE getBotConversationH) $ - zauth ZAuthBot - .&> zauthBotId - .&. zauthConvId - .&. accept "application" "json" - -getBotConversationH :: - forall r. - ( Member E.ConversationStore r, - Member (Input (Local ())) r, - Member (Input Opts) r, - Member TeamFeatureStore r, - Member (ErrorS 'AccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) => - BotId ::: ConvId ::: JSON -> - Sem r Response -getBotConversationH arg@(bid ::: cid ::: _) = - Features.guardSecondFactorDisabled (botUserId bid) cid (Query.getBotConversationH arg) - -type JSON = Media "application" "json" diff --git a/services/galley/src/Galley/API/Public/Bot.hs b/services/galley/src/Galley/API/Public/Bot.hs index 742008a9fe5..6a7dc0bd138 100644 --- a/services/galley/src/Galley/API/Public/Bot.hs +++ b/services/galley/src/Galley/API/Public/Bot.hs @@ -17,11 +17,47 @@ module Galley.API.Public.Bot where +import Data.Id +import Data.Qualified +import Galley.API.Query qualified as Query +import Galley.API.Teams.Features qualified as Features import Galley.API.Update import Galley.App +import Galley.Effects +import Galley.Effects qualified as E +import Galley.Options +import Imports hiding (head) +import Polysemy +import Polysemy.Input +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Event.Team qualified as Public () import Wire.API.Federation.API +import Wire.API.Provider.Bot import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Bot botAPI :: API BotAPI GalleyEffects -botAPI = mkNamedAPI @"post-bot-message-unqualified" (callsFed (exposeAnnotations postBotMessageUnqualified)) +botAPI = + mkNamedAPI @"post-bot-message-unqualified" (callsFed (exposeAnnotations postBotMessageUnqualified)) + <@> mkNamedAPI @"get-bot-conversation" getBotConversation + +getBotConversation :: + forall r. + ( Member E.ConversationStore r, + Member (Input (Local ())) r, + Member (Input Opts) r, + Member TeamFeatureStore r, + Member (ErrorS 'AccessDenied) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) => + BotId -> + ConvId -> + Sem r BotConvView +getBotConversation bid cnv = + Features.guardSecondFactorDisabled (botUserId bid) cnv $ + Query.getBotConversation bid cnv diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index e634b3f542b..f46696d34bb 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -18,7 +18,7 @@ -- with this program. If not, see . module Galley.API.Query - ( getBotConversationH, + ( getBotConversation, getUnqualifiedConversation, getConversation, getConversationRoles, @@ -79,9 +79,6 @@ import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Teams import Imports -import Network.Wai -import Network.Wai.Predicate hiding (Error, result, setStatus) -import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Input @@ -105,25 +102,16 @@ import Wire.API.Team.Feature as Public hiding (setStatus) import Wire.API.User import Wire.Sem.Paging.Cassandra -getBotConversationH :: +getBotConversation :: ( Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member (Input (Local ())) r ) => - BotId ::: ConvId ::: JSON -> - Sem r Response -getBotConversationH (zbot ::: zcnv ::: _) = do - lcnv <- qualifyLocal zcnv - json <$> getBotConversation zbot lcnv - -getBotConversation :: - ( Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r - ) => BotId -> - Local ConvId -> + ConvId -> Sem r Public.BotConvView -getBotConversation zbot lcnv = do +getBotConversation zbot cnv = do + lcnv <- qualifyLocal cnv (c, _) <- getConversationAndMemberWithError @'ConvNotFound (botUserId zbot) lcnv let domain = tDomain lcnv cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index f8a44b29b0a..d92aa3b2097 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -24,8 +24,7 @@ module Galley.API.Teams getTeamH, getTeamInternalH, getTeamNameInternalH, - getBindingTeamIdH, - getBindingTeamMembersH, + getBindingTeamMembers, getManyTeams, deleteTeam, uncheckedDeleteTeam, @@ -114,7 +113,6 @@ import Galley.Types.Teams import Galley.Types.UserList import Imports hiding (forkIO) import Network.Wai -import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Final @@ -1365,24 +1363,6 @@ finishCreateTeam team owner others zcon = do & pushConn .~ zcon ] -getBindingTeamIdH :: - ( Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'NonBindingTeam) r, - Member TeamStore r - ) => - UserId -> - Sem r Response -getBindingTeamIdH = fmap json . E.lookupBindingTeam - -getBindingTeamMembersH :: - ( Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'NonBindingTeam) r, - Member TeamStore r - ) => - UserId -> - Sem r Response -getBindingTeamMembersH = fmap json . getBindingTeamMembers - getBindingTeamMembers :: ( Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index ec436a030f6..750b9324ca3 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -66,10 +66,8 @@ module Galley.API.Update memberTyping, -- * External Services - addServiceH, - rmServiceH, - Galley.API.Update.addBotH, - rmBotH, + addBot, + rmBot, postBotMessageUnqualified, ) where @@ -105,22 +103,15 @@ import Galley.Effects.ConversationStore qualified as E import Galley.Effects.ExternalAccess qualified as E import Galley.Effects.FederatorAccess qualified as E import Galley.Effects.MemberStore qualified as E -import Galley.Effects.ServiceStore qualified as E -import Galley.Effects.WaiRoutes import Galley.Options -import Galley.Types.Bot hiding (addBot) -import Galley.Types.Bot.Service (Service) import Galley.Types.Conversations.Members (LocalMember (..)) import Galley.Types.UserList import Imports hiding (forkIO) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) -import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import Wire.API.Bot hiding (addBot) import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Code @@ -136,7 +127,6 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Password (mkSafePassword) -import Wire.API.Provider.Service (ServiceRef) import Wire.API.Routes.Public (ZHostValue) import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) @@ -261,11 +251,6 @@ unblockRemoteConv lusr rcnv = do -- conversation updates -handleUpdateResult :: UpdateResult Event -> Response -handleUpdateResult = \case - Updated ev -> json ev & setStatus status200 - Unchanged -> empty & setStatus status204 - type UpdateConversationAccessEffects = '[ BackendNotificationQueueAccess, BotAccess, @@ -1548,48 +1533,6 @@ memberTypingUnqualified lusr zcon cnv ts = do lcnv <- qualifyLocal cnv memberTyping lusr zcon (tUntagged lcnv) ts -addServiceH :: - ( Member ServiceStore r, - Member WaiRoutes r - ) => - JsonRequest Service -> - Sem r Response -addServiceH req = do - E.createService =<< fromJsonBody req - pure empty - -rmServiceH :: - ( Member ServiceStore r, - Member WaiRoutes r - ) => - JsonRequest ServiceRef -> - Sem r Response -rmServiceH req = do - E.deleteService =<< fromJsonBody req - pure empty - -addBotH :: - ( Member ClientStore r, - Member ConversationStore r, - Member (ErrorS ('ActionDenied 'AddConversationMember)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'TooManyMembers) r, - Member ExternalAccess r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input Opts) r, - Member (Input UTCTime) r, - Member MemberStore r, - Member WaiRoutes r - ) => - UserId ::: ConnId ::: JsonRequest AddBot -> - Sem r Response -addBotH (zusr ::: zcon ::: req) = do - bot <- fromJsonBody req - lusr <- qualifyLocal zusr - json <$> addBot lusr zcon bot - addBot :: forall r. ( Member ClientStore r, @@ -1648,25 +1591,6 @@ addBot lusr zcon b = do ensureMemberLimit (Data.convProtocolTag c) (toList $ Data.convLocalMembers c) [tUntagged botId] pure (bots, users) -rmBotH :: - ( Member ClientStore r, - Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member ExternalAccess r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member MemberStore r, - Member WaiRoutes r, - Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r - ) => - UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> - Sem r Response -rmBotH (zusr ::: zcon ::: req) = do - lusr <- qualifyLocal zusr - bot <- fromJsonBody req - handleUpdateResult <$> rmBot lusr zcon bot - rmBot :: ( Member ClientStore r, Member ConversationStore r, diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 0e9b8b1ee4a..dc4b824449e 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -47,6 +47,7 @@ import Galley.Data.Types qualified as DataTypes import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess import Galley.Effects.BrigAccess +import Galley.Effects.ClientStore import Galley.Effects.CodeStore import Galley.Effects.ConversationStore import Galley.Effects.ExternalAccess @@ -55,6 +56,7 @@ import Galley.Effects.LegalHoldStore import Galley.Effects.MemberStore import Galley.Effects.TeamStore import Galley.Options +import Galley.Types.Clients (Clients, fromUserClients) import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles import Galley.Types.Teams @@ -64,7 +66,6 @@ import Imports hiding (forkIO) import Network.AMQP qualified as Q import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (Error, fromEither) import Network.Wai.Utilities qualified as Wai import Polysemy import Polysemy.Error @@ -93,8 +94,6 @@ import Wire.API.User hiding (userId) import Wire.API.User.Auth.ReAuth import Wire.NotificationSubsystem -type JSON = Media "application" "json" - ensureAccessRole :: ( Member BrigAccess r, Member (ErrorS 'NotATeamMember) r, @@ -1054,6 +1053,18 @@ conversationExisted lusr cnv = Existed <$> conversationView lusr cnv getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList +getBrigClients :: + ( Member BrigAccess r, + Member ClientStore r + ) => + [UserId] -> + Sem r Clients +getBrigClients users = do + isInternal <- useIntraClientListing + if isInternal + then fromUserClients <$> lookupClients users + else getClients users + -------------------------------------------------------------------------------- -- Handling remote errors diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 445328a17fa..086fac2cad2 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -73,7 +73,6 @@ import Galley.Cassandra.TeamFeatures import Galley.Cassandra.TeamNotifications import Galley.Effects import Galley.Effects.FireAndForget -import Galley.Effects.WaiRoutes.IO import Galley.Env import Galley.External import Galley.Intra.BackendNotificationQueue @@ -258,7 +257,6 @@ evalGalley e = . interpretTinyLog e . interpretQueue (e ^. deleteQueue) . runInputSem (embed getCurrentTime) -- FUTUREWORK: could we take the time only once instead? - . interpretWaiRoutes . runInputConst (e ^. options) . runInputConst (toLocalUnsafe (e ^. options . settings . federationDomain) ()) . interpretTeamFeatureSpecialContext e diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index d1911434dd4..57ae885b673 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -30,8 +30,8 @@ import Data.ByteString.Lazy qualified as LBS import Data.Either.Combinators hiding (fromRight) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Galley.Types.Bot () import Imports +import Wire.API.Bot () import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.MLS.CipherSuite diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index 47810380b34..7e8012e2998 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -25,12 +25,12 @@ import Galley.Cassandra.Store import Galley.Cassandra.Util import Galley.Data.Services import Galley.Effects.ServiceStore hiding (deleteService) -import Galley.Types.Bot.Service qualified as Bot import Galley.Types.Conversations.Members (lmService, newMember) import Imports import Polysemy import Polysemy.Input import Polysemy.TinyLog +import Wire.API.Bot.Service qualified as Bot import Wire.API.Provider.Service hiding (DeleteService) -- FUTUREWORK: support adding bots to a remote conversation diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 7138512bd18..35279a4882e 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -53,7 +53,6 @@ module Galley.Effects -- * Other effects Queue, - WaiRoutes, -- * Polysemy re-exports Member, @@ -90,7 +89,6 @@ import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore -import Galley.Effects.WaiRoutes import Galley.Env import Galley.Options import Galley.Types.Teams (FeatureLegalHold) @@ -144,7 +142,6 @@ type GalleyEffects1 = Input (Maybe [TeamId], FeatureLegalHold), Input (Local ()), Input Opts, - WaiRoutes, Input UTCTime, Queue DeleteItem, TinyLog, diff --git a/services/galley/src/Galley/Effects/ServiceStore.hs b/services/galley/src/Galley/Effects/ServiceStore.hs index c7affe084b4..18949b7a476 100644 --- a/services/galley/src/Galley/Effects/ServiceStore.hs +++ b/services/galley/src/Galley/Effects/ServiceStore.hs @@ -32,9 +32,9 @@ module Galley.Effects.ServiceStore ) where -import Galley.Types.Bot.Service import Imports import Polysemy +import Wire.API.Bot.Service import Wire.API.Provider.Service (ServiceRef) data ServiceStore m a where diff --git a/services/galley/src/Galley/Effects/WaiRoutes.hs b/services/galley/src/Galley/Effects/WaiRoutes.hs deleted file mode 100644 index 37c80171aa9..00000000000 --- a/services/galley/src/Galley/Effects/WaiRoutes.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- 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 Galley.Effects.WaiRoutes - ( WaiRoutes (..), - fromJsonBody, - fromOptionalJsonBody, - fromProtoBody, - ) -where - -import Data.Aeson (FromJSON) -import Data.ProtocolBuffers qualified as Proto -import Imports -import Network.Wai -import Network.Wai.Utilities hiding (Error) -import Polysemy - -data WaiRoutes m a where - FromJsonBody :: FromJSON a => JsonRequest a -> WaiRoutes m a - FromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> WaiRoutes m (Maybe a) - FromProtoBody :: Proto.Decode a => Request -> WaiRoutes m a - -makeSem ''WaiRoutes diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs deleted file mode 100644 index 69da6a3824a..00000000000 --- a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs +++ /dev/null @@ -1,41 +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 . - -module Galley.Effects.WaiRoutes.IO where - -import Control.Error -import Data.ProtocolBuffers qualified as Proto -import Data.Serialize.Get -import Galley.API.Error -import Galley.Effects.WaiRoutes -import Imports -import Network.Wai.Utilities hiding (Error) -import Polysemy -import Polysemy.Error - -interpretWaiRoutes :: - ( Member (Embed IO) r, - Member (Error InvalidInput) r - ) => - Sem (WaiRoutes ': r) a -> - Sem r a -interpretWaiRoutes = interpret $ \case - FromJsonBody r -> exceptT (throw . InvalidPayload) pure (parseBody r) - FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) pure (parseOptionalBody r) - FromProtoBody r -> do - b <- readBody r - either (throw . InvalidPayload . fromString) pure (runGetLazy Proto.decodeMessage b) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index c1bf5eecc48..c7ea60ed63d 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -33,7 +33,6 @@ import Galley.Effects.ExternalAccess (ExternalAccess (..)) import Galley.Env import Galley.Intra.User import Galley.Monad -import Galley.Types.Bot.Service (Service, serviceEnabled, serviceFingerprints, serviceToken, serviceUrl) import Imports import Network.HTTP.Client qualified as Http import Network.HTTP.Types.Method @@ -46,6 +45,7 @@ import System.Logger.Class qualified as Log import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +import Wire.API.Bot.Service import Wire.API.Event.Conversation (Event) import Wire.API.Provider.Service (serviceRefId, serviceRefProvider) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 744e9dc4220..c54804f6c39 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -37,15 +37,15 @@ import Data.Id import Data.Metrics (Metrics) import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Middleware qualified as M -import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) +import Data.Metrics.Servant import Data.Misc (portNumber) import Data.Singletons import Data.Text (unpack) import Data.UUID as UUID import Data.UUID.V4 as UUID -import Galley.API qualified as API import Galley.API.Federation import Galley.API.Internal +import Galley.API.Public.Servant import Galley.App import Galley.App qualified as App import Galley.Aws (awsEnv) @@ -59,6 +59,7 @@ import Network.HTTP.Types qualified as HTTP import Network.Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip +import Network.Wai.Utilities.Error import Network.Wai.Utilities.Server import Servant hiding (route) import System.Logger (Logger, msg, val, (.=), (~~)) @@ -98,7 +99,7 @@ mkApp opts = lift $ runClient (env ^. cstate) $ versionCheck schemaVersion let middlewares = versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) - . servantPlusWAIPrometheusMiddleware API.waiSitemap (Proxy @CombinedAPI) + . servantPrometheusMiddleware (Proxy @CombinedAPI) . GZip.gunzip . GZip.gzip GZip.def . catchErrors logger [Right metrics] @@ -108,8 +109,27 @@ mkApp opts = Log.close logger pure (middlewares $ servantApp env, env) where - rtree = compile API.waiSitemap - runGalley e r k = evalGalleyToIO e (route rtree r k) + -- Used as a last case in the servant tree. Previously, there used to be a + -- wai-routing application in that position. That was causing any `Fail` + -- route results in any servant endpoint to be recovered and ultimately + -- report a 404 since no other matching path would normally be found in + -- the wai-routing application. Now there is no wai-routing application + -- anymore, so without this fallback, any `Fail` result would commit to the + -- failed endpoint and return the error for that specific path, which would + -- break compatibility with older API versions. + -- + -- Note that, since we have many overlapping paths (e.g. + -- `/conversations/:uuid` and `/conversations/list`), even without the + -- fallback, errors would not entirely be consistent. For example, a `Fail` + -- result when attempting to call `/conversations/list`, say if the content + -- type is incorrect, would cause `conversations/:uuid` to be matched and + -- report a 400 `invalid UUID` error. + fallback :: Application + fallback _ k = + k $ + responseLBS HTTP.status404 [("Content-Type", "application/json")] $ + Aeson.encode $ + mkError HTTP.status404 "no-endpoint" "The requested endpoint does not exist" -- the servant API wraps the one defined using wai-routing servantApp :: Env -> Application @@ -122,10 +142,10 @@ mkApp opts = :. customFormatters :. Servant.EmptyContext ) - ( hoistAPIHandler (toServantHandler e) API.servantSitemap + ( hoistAPIHandler (toServantHandler e) servantSitemap :<|> hoistAPIHandler (toServantHandler e) internalAPI :<|> hoistServerWithDomain @FederationAPI (toServantHandler e) federationSitemap - :<|> Servant.Tagged (runGalley e) + :<|> Tagged fallback ) r cont @@ -171,7 +191,7 @@ type CombinedAPI = GalleyAPI :<|> InternalAPI :<|> FederationAPI - :<|> Servant.Raw + :<|> Raw refreshMetrics :: App () refreshMetrics = do diff --git a/services/galley/test/integration/Run.hs b/services/galley/test/integration/Run.hs index 149c9352628..a5d212c39b4 100644 --- a/services/galley/test/integration/Run.hs +++ b/services/galley/test/integration/Run.hs @@ -28,27 +28,22 @@ import Cassandra.Util import Control.Lens import Data.ByteString.Char8 qualified as BS import Data.ByteString.Conversion -import Data.Metrics.Test (pathsConsistencyCheck) -import Data.Metrics.WaiRoute (treeToPaths) import Data.Proxy import Data.Tagged import Data.Text (pack) import Data.Text.Encoding (encodeUtf8) import Data.Yaml (decodeFileEither) import Federation -import Galley.API import Galley.Aws qualified as Aws import Galley.Options hiding (endpoint) import Galley.Options qualified as O import Imports hiding (local) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Network.Wai.Utilities.Server (compile) import OpenSSL (withOpenSSL) import Options.Applicative import System.Logger.Class qualified as Logger import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.Ingredients import Test.Tasty.Ingredients.Basic import Test.Tasty.Options @@ -97,12 +92,7 @@ main = withOpenSSL $ runTests go go g i = withResource (getOpts g i) releaseOpts $ \setup -> testGroup "galley" - [ testCase "sitemap" $ - assertEqual - "inconsistent sitemap" - mempty - (pathsConsistencyCheck . treeToPaths . compile $ Galley.API.waiSitemap), - API.tests setup, + [ API.tests setup, test setup "isConvMemberL" isConvMemberLTests ] getOpts gFile iFile = do From 8cde3afa17023985a64fbc27ef6db2079e1ffba5 Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Tue, 30 Apr 2024 12:49:04 +0200 Subject: [PATCH 05/30] Use makefile targets again (#4029) * Revert "[chore] don't use treeefmt for hlint, readd the remove hlint rules (#4028)" This reverts commit aef2f57b2e611a9c192c3418059321c563adf72e. * Revert "[WPB-8712] use treefmt for everything (#4000)" This reverts commit 2d5073eb1ed15567b0abb2e6e6fd6f6e01dde207. --- Makefile | 43 ++++++++++++++++++++----------------------- treefmt.toml | 15 +++++---------- 2 files changed, 25 insertions(+), 33 deletions(-) diff --git a/Makefile b/Makefile index 5791fd46ac6..0ffa86792f2 100644 --- a/Makefile +++ b/Makefile @@ -129,8 +129,9 @@ devtest: .PHONY: sanitize-pr sanitize-pr: ./hack/bin/generate-local-nix-packages.sh + make formatf make hlint-inplace-pr - make format + make hlint-check-pr # sometimes inplace has been observed not to do its job very well. make git-add-cassandra-schema @git diff-files --quiet -- || ( echo "There are unstaged changes, please take a look, consider committing them, and try again."; exit 1 ) @git diff-index --quiet --cached HEAD -- || ( echo "There are staged changes, please take a look, consider committing them, and try again."; exit 1 ) @@ -154,7 +155,7 @@ ghcid: # Used by CI .PHONY: lint-all -lint-all: treefmt-check check-local-nix-derivations hlint-check-all +lint-all: formatc hlint-check-all check-local-nix-derivations treefmt-check .PHONY: hlint-check-all hlint-check-all: @@ -180,18 +181,6 @@ hlint-check: hlint-inplace: ./tools/hlint.sh -f changeset -m inplace -.PHONY: hlint-inplace-all -hlint-inplace-all: - ./tools/hlint.sh -f all -m inplace - -.PHONY: hlint-inplace-pr -hlint-inplace-pr: - ./tools/hlint.sh -f pr -m inplace - -.PHONY: hlint-inplace -hlint-inplace: - ./tools/hlint.sh -f changeset -m inplace - regen-local-nix-derivations: ./hack/bin/generate-local-nix-packages.sh @@ -203,27 +192,35 @@ check-local-nix-derivations: regen-local-nix-derivations services: init install $(MAKE) -C services/nginz -# formats everything according to treefmt rules -# this may take a while (5 minutes) on first run but should be instant on -# any subsequent run except after you have changed files. +# formats all Haskell files (which don't contain CPP) .PHONY: format format: - treefmt + ./tools/ormolu.sh + +# formats all Haskell files changed in this PR, even if local changes are not committed to git +.PHONY: formatf +formatf: + ./tools/ormolu.sh -f pr + +# formats all Haskell files even if local changes are not committed to git +.PHONY: formatf-all +formatf-all: + ./tools/ormolu.sh -f all -# checks the format +# checks that all Haskell files are formatted; fail if a `make format` run is needed. .PHONY: formatc -formatc: - treefmt-check +formatc: + ./tools/ormolu.sh -c # For any Haskell or Rust file, update or add a license header if necessary. # Headers should be added according to Ormolu's formatting rules, but please check just in case. .PHONY: add-license add-license: - # Check headroom is installed. + # Check headroom is installed. If not, please run 'stack install headroom' command -v headroom headroom run @echo "" - @echo "you might want to run 'make format' now to make sure ormolu is happy" + @echo "you might want to run 'make formatf' now to make sure ormolu is happy" .PHONY: treefmt treefmt: diff --git a/treefmt.toml b/treefmt.toml index dce24e184d6..6d5723fc9ef 100644 --- a/treefmt.toml +++ b/treefmt.toml @@ -1,21 +1,16 @@ [formatter.nix] command = "nixpkgs-fmt" includes = ["*.nix"] -excludes = [ "nix/sources.nix"] # managed by niv. +excludes = [ + "nix/sources.nix" # managed by niv. +] [formatter.cabal-fmt] command = "cabal-fmt" options = [ "--inplace" ] includes = [ "*.cabal" ] -excludes = [ "dist-newstyle/" ] - -[formatter.ormolu] -command = "ormolu" -includes = ["*.hs"] -excludes = [ "dist*" ] -options = [ - "--mode", "inplace", - "--check-idempotence", +excludes = [ + "dist-newstyle/" ] [formatter.shellcheck] From 68a6e98b4528beb8a08332b232d63354ddd188e3 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 30 Apr 2024 17:10:52 +0200 Subject: [PATCH 06/30] inbucket: allow configuration of issuer (#4031) --- charts/inbucket/templates/cert.yaml | 8 ++------ charts/inbucket/templates/issuer.yaml | 27 --------------------------- charts/inbucket/values.yaml | 6 +++--- 3 files changed, 5 insertions(+), 36 deletions(-) delete mode 100644 charts/inbucket/templates/issuer.yaml diff --git a/charts/inbucket/templates/cert.yaml b/charts/inbucket/templates/cert.yaml index 3d6996212f8..7a0aeb7bd63 100644 --- a/charts/inbucket/templates/cert.yaml +++ b/charts/inbucket/templates/cert.yaml @@ -7,14 +7,10 @@ metadata: chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" release: "{{ .Release.Name }}" heritage: "{{ .Release.Service }}" - annotations: - # The issuer changes when it's configured to use staging or prod ACME - # servers. - checksum/issuer: {{ include (print .Template.BasePath "/issuer.yaml") . | sha256sum }} spec: issuerRef: - name: letsencrypt-inbucket - kind: Issuer + {{- toYaml .Values.issuerRef | nindent 4 }} + usages: - server auth duration: 2160h # 90d, Letsencrypt default; NOTE: changes are ignored by Letsencrypt diff --git a/charts/inbucket/templates/issuer.yaml b/charts/inbucket/templates/issuer.yaml deleted file mode 100644 index d3f1d1bc94f..00000000000 --- a/charts/inbucket/templates/issuer.yaml +++ /dev/null @@ -1,27 +0,0 @@ -apiVersion: cert-manager.io/v1 -kind: Issuer -metadata: - name: letsencrypt-inbucket - namespace: {{ .Release.Namespace }} - labels: - app.kubernetes.io/name: {{ include "inbucket.name" . }} - app.kubernetes.io/instance: {{ .Release.Name }} - app.kubernetes.io/managed-by: {{ .Release.Service }} - helm.sh/chart: {{ include "inbucket.chart" . }} -spec: - acme: -{{- if .Values.useStagingACMEServer }} - server: https://acme-staging-v02.api.letsencrypt.org/directory -{{- else }} - server: https://acme-v02.api.letsencrypt.org/directory -{{- end }} - # Email address used for ACME registration - email: {{ required "must specify certManager.certmasterEmail" .Values.certManager.certmasterEmail | quote }} - # Name of a secret used to store the ACME account private key - privateKeySecretRef: - name: letsencrypt-inbucket-key - # Enable the HTTP-01 challenge provider - solvers: - - http01: - ingress: - class: nginx diff --git a/charts/inbucket/values.yaml b/charts/inbucket/values.yaml index d438b634748..14511177c4e 100644 --- a/charts/inbucket/values.yaml +++ b/charts/inbucket/values.yaml @@ -15,9 +15,9 @@ inbucket: INBUCKET_MAILBOXNAMING: full INBUCKET_STORAGE_RETENTIONPERIOD: "72h" -# The production ACME server of let's encrypt has a very strict rate limiting -# and bans for weeks. Better try with the staging ACME server first. -useStagingACMEServer: true +# issuerRef: +# kind: ClusterIssuer +# name: letsencrypt # Enables and configures HTTP Basic Auth secret as e.g. created with # `htpasswd -bc auth username password`. From 523702a1ede742b10c3c5f1adf8d7b81e948ca94 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 30 Apr 2024 17:39:30 +0200 Subject: [PATCH 07/30] Remove inbucket Helm chart (#4032) --- Makefile | 2 +- changelog.d/5-internal/remove-inbucket | 1 + charts/inbucket/Chart.yaml | 10 ---- charts/inbucket/README.md | 10 ---- charts/inbucket/requirements.yaml | 4 -- charts/inbucket/templates/_helpers.tpl | 30 ------------ .../inbucket/templates/basic-auth-secret.yaml | 15 ------ charts/inbucket/templates/cert.yaml | 28 ----------- charts/inbucket/templates/ingress.yaml | 48 ------------------- charts/inbucket/values.yaml | 25 ---------- 10 files changed, 2 insertions(+), 171 deletions(-) create mode 100644 changelog.d/5-internal/remove-inbucket delete mode 100644 charts/inbucket/Chart.yaml delete mode 100644 charts/inbucket/README.md delete mode 100644 charts/inbucket/requirements.yaml delete mode 100644 charts/inbucket/templates/_helpers.tpl delete mode 100644 charts/inbucket/templates/basic-auth-secret.yaml delete mode 100644 charts/inbucket/templates/cert.yaml delete mode 100644 charts/inbucket/templates/ingress.yaml delete mode 100644 charts/inbucket/values.yaml diff --git a/Makefile b/Makefile index 0ffa86792f2..f34ffcdb77a 100644 --- a/Makefile +++ b/Makefile @@ -18,7 +18,7 @@ fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice \ calling-test demo-smtp elasticsearch-curator elasticsearch-external \ elasticsearch-ephemeral minio-external cassandra-external \ nginx-ingress-controller ingress-nginx-controller nginx-ingress-services reaper restund coturn \ -inbucket k8ssandra-test-cluster postgresql ldap-scim-bridge smallstep-accomp +k8ssandra-test-cluster postgresql ldap-scim-bridge smallstep-accomp KIND_CLUSTER_NAME := wire-server HELM_PARALLELISM ?= 1 # 1 for sequential tests; 6 for all-parallel tests diff --git a/changelog.d/5-internal/remove-inbucket b/changelog.d/5-internal/remove-inbucket new file mode 100644 index 00000000000..d4a77b0fc3d --- /dev/null +++ b/changelog.d/5-internal/remove-inbucket @@ -0,0 +1 @@ +Remove inbucket helm chart. diff --git a/charts/inbucket/Chart.yaml b/charts/inbucket/Chart.yaml deleted file mode 100644 index 9c440f0ab9d..00000000000 --- a/charts/inbucket/Chart.yaml +++ /dev/null @@ -1,10 +0,0 @@ -apiVersion: v1 -name: inbucket -version: 0.0.42 -description: Inbucket is an email testing application; it will accept messages for any email address and make them available to view via a web interface. -home: https://www.inbucket.org/ -sources: - - https://github.com/inbucket/inbucket - - https://artifacthub.io/packages/helm/inbucket/inbucket - - https://hub.docker.com/r/inbucket/inbucket -appVersion: 3.0.0 diff --git a/charts/inbucket/README.md b/charts/inbucket/README.md deleted file mode 100644 index 8fd97254a2d..00000000000 --- a/charts/inbucket/README.md +++ /dev/null @@ -1,10 +0,0 @@ -# Inbucket chart - -[*Inbucket*](https://www.inbucket.org/) is a fake SMTP server that provides all -captured eMails via a webapp and a REST API. At *Wire* it is used in testing -environments to not have to deal with concrete SMTP server configurations. -Especially, it saves us to care about topics like *SPAM filters* and *server -grey & black listing*. - -This chart exists to adjust the [`inbucket/inbucket` -chart](https://artifacthub.io/packages/helm/inbucket/inbucket) to our needs. diff --git a/charts/inbucket/requirements.yaml b/charts/inbucket/requirements.yaml deleted file mode 100644 index 47adf720b7d..00000000000 --- a/charts/inbucket/requirements.yaml +++ /dev/null @@ -1,4 +0,0 @@ -dependencies: -- name: inbucket - version: 2.1.0 - repository: https://inbucket.github.io/inbucket-community diff --git a/charts/inbucket/templates/_helpers.tpl b/charts/inbucket/templates/_helpers.tpl deleted file mode 100644 index da39aad074a..00000000000 --- a/charts/inbucket/templates/_helpers.tpl +++ /dev/null @@ -1,30 +0,0 @@ -{{/* Allow KubeVersion to be overridden. */}} -{{- define "kubeVersion" -}} - {{- default .Capabilities.KubeVersion.Version .Values.kubeVersionOverride -}} -{{- end -}} - -{{/* Get Ingress API Version */}} -{{- define "ingress.apiVersion" -}} - {{- if and (.Capabilities.APIVersions.Has "networking.k8s.io/v1") (semverCompare ">= 1.19-0" (include "kubeVersion" .)) -}} - {{- print "networking.k8s.io/v1" -}} - {{- else if .Capabilities.APIVersions.Has "networking.k8s.io/v1beta1" -}} - {{- print "networking.k8s.io/v1beta1" -}} - {{- else -}} - {{- print "extensions/v1beta1" -}} - {{- end -}} -{{- end -}} - -{{/* Check Ingress stability */}} -{{- define "ingress.isStable" -}} - {{- eq (include "ingress.apiVersion" .) "networking.k8s.io/v1" -}} -{{- end -}} - -{{/* Check Ingress supports pathType */}} -{{/* pathType was added to networking.k8s.io/v1beta1 in Kubernetes 1.18 */}} -{{- define "ingress.supportsPathType" -}} - {{- or (eq (include "ingress.isStable" .) "true") (and (eq (include "ingress.apiVersion" .) "networking.k8s.io/v1beta1") (semverCompare ">= 1.18-0" (include "kubeVersion" .))) -}} -{{- end -}} - -{{- define "ingress.FieldNotAnnotation" -}} - {{- (semverCompare ">= 1.27-0" (include "kubeVersion" .)) -}} -{{- end -}} diff --git a/charts/inbucket/templates/basic-auth-secret.yaml b/charts/inbucket/templates/basic-auth-secret.yaml deleted file mode 100644 index 9918cbb7163..00000000000 --- a/charts/inbucket/templates/basic-auth-secret.yaml +++ /dev/null @@ -1,15 +0,0 @@ -{{- if (hasKey .Values "basicAuthSecret") }} -apiVersion: v1 -kind: Secret -metadata: - name: inbucket-basic-auth - namespace: {{ .Release.Namespace }} - labels: - app.kubernetes.io/name: {{ include "inbucket.name" . }} - app.kubernetes.io/instance: {{ .Release.Name }} - app.kubernetes.io/managed-by: {{ .Release.Service }} - helm.sh/chart: {{ include "inbucket.chart" . }} -type: Opaque -data: - auth: {{ .Values.basicAuthSecret | b64enc | quote }} -{{- end }} diff --git a/charts/inbucket/templates/cert.yaml b/charts/inbucket/templates/cert.yaml deleted file mode 100644 index 7a0aeb7bd63..00000000000 --- a/charts/inbucket/templates/cert.yaml +++ /dev/null @@ -1,28 +0,0 @@ -apiVersion: cert-manager.io/v1 -kind: Certificate -metadata: - name: "letsencrypt-inbucket-csr" - namespace: {{ .Release.Namespace }} - labels: - chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" - release: "{{ .Release.Name }}" - heritage: "{{ .Release.Service }}" -spec: - issuerRef: - {{- toYaml .Values.issuerRef | nindent 4 }} - - usages: - - server auth - duration: 2160h # 90d, Letsencrypt default; NOTE: changes are ignored by Letsencrypt - renewBefore: 360h # 15d - isCA: false - secretName: letsencrypt-inbucket-secret - - privateKey: - algorithm: ECDSA - size: 384 # 521 is not supported by Letsencrypt - encoding: PKCS1 - rotationPolicy: Always - - dnsNames: - - {{ .Values.host }} diff --git a/charts/inbucket/templates/ingress.yaml b/charts/inbucket/templates/ingress.yaml deleted file mode 100644 index 77c30a7df1a..00000000000 --- a/charts/inbucket/templates/ingress.yaml +++ /dev/null @@ -1,48 +0,0 @@ -{{- $apiIsStable := eq (include "ingress.isStable" .) "true" -}} -{{- $ingressFieldNotAnnotation := eq (include "ingress.FieldNotAnnotation" .) "true" -}} -{{- $ingressSupportsPathType := eq (include "ingress.supportsPathType" .) "true" -}} -apiVersion: {{ include "ingress.apiVersion" . }} -kind: Ingress -metadata: - name: "inbucket" - namespace: {{ .Release.Namespace }} - labels: - app.kubernetes.io/name: {{ include "inbucket.name" . }} - app.kubernetes.io/instance: {{ .Release.Name }} - app.kubernetes.io/managed-by: {{ .Release.Service }} - helm.sh/chart: {{ include "inbucket.chart" . }} - annotations: - {{- if not $ingressFieldNotAnnotation }} - kubernetes.io/ingress.class: "{{ .Values.config.ingressClass }}" - {{- end }} -{{- if (hasKey .Values "basicAuthSecret") }} - nginx.ingress.kubernetes.io/auth-type: basic - nginx.ingress.kubernetes.io/auth-secret: inbucket-basic-auth - nginx.ingress.kubernetes.io/auth-realm: 'Authentication Required - inbucket' -{{- end }} -spec: - {{- if $ingressFieldNotAnnotation }} - ingressClassName: "{{ .Values.config.ingressClass }}" - {{- end }} - tls: - - hosts: - - {{ required "must specify host" .Values.host | quote }} - secretName: letsencrypt-inbucket-secret - rules: - - host: {{ required "must specify host" .Values.host | quote }} - http: - paths: - - path: / - {{- if $ingressSupportsPathType }} - pathType: Prefix - {{- end }} - backend: - {{- if $apiIsStable }} - service: - name: {{ include "inbucket.fullname" . }} - port: - name: http - {{- else }} - serviceName: {{ include "inbucket.fullname" . }} - servicePort: http - {{- end }} diff --git a/charts/inbucket/values.yaml b/charts/inbucket/values.yaml deleted file mode 100644 index 14511177c4e..00000000000 --- a/charts/inbucket/values.yaml +++ /dev/null @@ -1,25 +0,0 @@ -# Fully qualified domain name (FQDN) of the domain where to serve inbucket. -# E.g. 'inbucket.my-test-env.wire.link' -host: "inbucket.wire.example" - -config: - ingressClass: "nginx" - -# Configure the inbucket "parent" chart -inbucket: - image: - tag: 3.0.2 - - extraEnv: - INBUCKET_WEB_GREETINGFILE: "/config/greeting.html" - INBUCKET_MAILBOXNAMING: full - INBUCKET_STORAGE_RETENTIONPERIOD: "72h" - -# issuerRef: -# kind: ClusterIssuer -# name: letsencrypt - -# Enables and configures HTTP Basic Auth secret as e.g. created with -# `htpasswd -bc auth username password`. -# -# basicAuthSecret: username:$apr1$3jXFMMZX$z6OOf4eUn1wU.NYJt246u1 From 083263faa9451795a037307a9e9ebc42998766a0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 2 May 2024 16:30:50 +0200 Subject: [PATCH 08/30] Introduce user subsystem (#3977) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tracked by WPB-5990. --------- Co-authored-by: Marko Dimjašević Co-authored-by: Paolo Capriotti Co-authored-by: Magnus Viernickel Co-authored-by: Matthias Fischmann Co-authored-by: Igor Ranieri --- .hlint.yaml | 1 + .../5-internal/wpb-5990-begin-user-subsystem | 1 + .../polysemy-wire-zoo/src/Wire/Sem/FromUTC.hs | 3 - .../src/Wire/Sem/Now/Input.hs | 9 +- libs/types-common/src/Data/LegalHold.hs | 12 +- .../src/Wire/API/Federation/API.hs | 48 ++- .../src/Wire/API/Federation/Version.hs | 5 + libs/wire-api/src/Wire/API/Asset.hs | 4 +- .../src/Wire/API/Routes/Public/Brig.hs | 4 +- libs/wire-api/src/Wire/API/User.hs | 44 +-- libs/wire-api/src/Wire/API/User/Identity.hs | 13 + libs/wire-api/src/Wire/API/User/Profile.hs | 8 +- libs/wire-subsystems/default.nix | 68 +++++ libs/wire-subsystems/src/Wire/DeleteQueue.hs | 14 + .../src/Wire/DeleteQueue/InMemory.hs | 13 + .../src/Wire/FederationAPIAccess.hs | 46 +++ .../Wire/FederationAPIAccess/Interpreter.hs | 93 ++++++ .../src/Wire/GalleyAPIAccess.hs | 53 ++-- .../src/Wire/GalleyAPIAccess/Rpc.hs | 46 +-- .../wire-subsystems/src/Wire/InternalEvent.hs | 83 +++++ libs/wire-subsystems/src/Wire/MiniBackend.hs | 288 ++++++++++++++++++ .../src/Wire/ParseException.hs | 18 ++ libs/wire-subsystems/src/Wire/StoredUser.hs | 91 ++++++ libs/wire-subsystems/src/Wire/UserStore.hs | 13 + .../src/Wire/UserStore/Cassandra.hs | 28 ++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 29 ++ .../src/Wire/UserSubsystem/Interpreter.hs | 240 +++++++++++++++ .../NotificationSubsystem/InterpreterSpec.hs | 20 +- .../test/unit/Wire/UserStoreSpec.hs | 36 +++ .../Wire/UserSubsystem/InterpreterSpec.hs | 189 ++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 57 ++++ services/brig/brig.cabal | 5 +- services/brig/default.nix | 1 + services/brig/src/Brig/API/Auth.hs | 8 +- services/brig/src/Brig/API/Client.hs | 57 +++- services/brig/src/Brig/API/Connection.hs | 22 +- .../brig/src/Brig/API/Connection/Remote.hs | 12 +- services/brig/src/Brig/API/Federation.hs | 39 ++- services/brig/src/Brig/API/Internal.hs | 43 +-- services/brig/src/Brig/API/Public.hs | 127 ++++---- services/brig/src/Brig/API/User.hs | 224 +++----------- services/brig/src/Brig/App.hs | 33 +- .../brig/src/Brig/CanonicalInterpreter.hs | 68 ++++- .../brig/src/Brig/DeleteQueue/Interpreter.hs | 72 +++++ services/brig/src/Brig/IO/Journal.hs | 2 + services/brig/src/Brig/Options.hs | 4 +- services/brig/src/Brig/Provider/API.hs | 100 +++--- services/brig/src/Brig/Provider/RPC.hs | 1 + services/brig/src/Brig/Queue.hs | 68 ++--- services/brig/src/Brig/Queue/Types.hs | 12 +- services/brig/src/Brig/RPC.hs | 17 +- services/brig/src/Brig/Run.hs | 12 +- services/brig/src/Brig/Team/API.hs | 43 ++- services/brig/src/Brig/Team/DB.hs | 2 +- services/brig/src/Brig/Team/Types.hs | 23 -- services/brig/src/Brig/Team/Util.hs | 14 +- services/brig/src/Brig/User/API/Handle.hs | 10 +- services/brig/src/Brig/User/API/Search.hs | 18 +- services/brig/src/Brig/User/Auth.hs | 18 +- services/brig/src/Brig/User/EJPD.hs | 8 +- .../brig/test/integration/API/User/Account.hs | 27 +- .../unit/Test/Brig/InternalNotification.hs | 2 +- services/spar/test/Test/Spar/Sem/NowSpec.hs | 3 +- tools/stern/test/integration/Util.hs | 4 +- 64 files changed, 2019 insertions(+), 657 deletions(-) create mode 100644 changelog.d/5-internal/wpb-5990-begin-user-subsystem create mode 100644 libs/wire-subsystems/src/Wire/DeleteQueue.hs create mode 100644 libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs create mode 100644 libs/wire-subsystems/src/Wire/FederationAPIAccess.hs create mode 100644 libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs rename services/brig/src/Brig/Effects/GalleyProvider.hs => libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs (72%) rename services/brig/src/Brig/Effects/GalleyProvider/RPC.hs => libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs (93%) create mode 100644 libs/wire-subsystems/src/Wire/InternalEvent.hs create mode 100644 libs/wire-subsystems/src/Wire/MiniBackend.hs create mode 100644 libs/wire-subsystems/src/Wire/ParseException.hs create mode 100644 libs/wire-subsystems/src/Wire/StoredUser.hs create mode 100644 libs/wire-subsystems/src/Wire/UserStore.hs create mode 100644 libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSubsystem.hs create mode 100644 libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs create mode 100644 services/brig/src/Brig/DeleteQueue/Interpreter.hs delete mode 100644 services/brig/src/Brig/Team/Types.hs diff --git a/.hlint.yaml b/.hlint.yaml index b5b237ee5fa..9fa143c7cba 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -13,6 +13,7 @@ - ignore: { name: Use section } - ignore: { name: "Use :" } - ignore: { name: Use underscore } +- ignore: { name: Use error } # custom rules: - hint: { lhs: (() <$), rhs: void } diff --git a/changelog.d/5-internal/wpb-5990-begin-user-subsystem b/changelog.d/5-internal/wpb-5990-begin-user-subsystem new file mode 100644 index 00000000000..d74501002ea --- /dev/null +++ b/changelog.d/5-internal/wpb-5990-begin-user-subsystem @@ -0,0 +1 @@ +New subsystem for user management. \ No newline at end of file diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/FromUTC.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/FromUTC.hs index 3f339fd5819..4d3871c0c26 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/FromUTC.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/FromUTC.hs @@ -30,14 +30,11 @@ import Wire.API.MLS.Epoch (Epoch (..)) class FromUTC a where fromUTCTime :: UTCTime -> a --- An orphan instance instance FromUTC UTCTime where fromUTCTime = id --- An orphan instance instance FromUTC SAML.Time where fromUTCTime = SAML.Time --- An orphan instance instance FromUTC Epoch where fromUTCTime = Epoch . floor . utcTimeToPOSIXSeconds diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs index 1a7a84854a5..b8c43249f9d 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Now/Input.hs @@ -18,22 +18,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.Sem.Now.Input - ( nowToInput, - ) -where +module Wire.Sem.Now.Input (nowToInput) where import Data.Time (UTCTime) import Imports import Polysemy import Polysemy.Input -import Wire.Sem.FromUTC (FromUTC (..)) import Wire.Sem.Now nowToInput :: - FromUTC t => Member (Input UTCTime) r => Sem (Now ': r) a -> Sem r a nowToInput = interpret $ \case - Get -> fromUTCTime <$> input + Get -> input diff --git a/libs/types-common/src/Data/LegalHold.hs b/libs/types-common/src/Data/LegalHold.hs index 02955c03f3d..247684fee78 100644 --- a/libs/types-common/src/Data/LegalHold.hs +++ b/libs/types-common/src/Data/LegalHold.hs @@ -26,10 +26,14 @@ import Imports import Test.QuickCheck data UserLegalHoldStatus - = UserLegalHoldDisabled - | UserLegalHoldPending - | UserLegalHoldEnabled - | UserLegalHoldNoConsent + = -- | consent is given, but no device creation request has come in yet. + UserLegalHoldDisabled + | -- | device creation request has come in, waiting for 2nd round of ok from user before creating client device + UserLegalHoldPending + | -- | lh client ok'ed, requested, and created. + UserLegalHoldEnabled + | -- | no consent given (not even implicit) + UserLegalHoldNoConsent deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via Schema UserLegalHoldStatus diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 053275577e3..89ba99b4e6a 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -22,6 +22,9 @@ module Wire.API.Federation.API ( FedApi, HasFedEndpoint, HasUnsafeFedEndpoint, + FederationMonad (..), + IsNamed (..), + nameVal, fedClient, fedQueueClient, sendBundle, @@ -39,6 +42,8 @@ import Data.Aeson import Data.Domain import Data.Kind import Data.Proxy +import Data.Singletons +import Data.Text qualified as Text import GHC.TypeLits import Imports import Network.AMQP @@ -53,6 +58,7 @@ import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint +import Wire.API.Federation.Version import Wire.API.MakesFederatedCall import Wire.API.Routes.Named @@ -73,6 +79,35 @@ type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name) -- you to forget about some federated calls. type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi comp) name +nameVal :: forall {k} (name :: k). IsNamed name => Text +nameVal = nameVal' @k @name + +class IsNamed (name :: k) where + nameVal' :: Text + +instance KnownSymbol name => IsNamed (name :: Symbol) where + nameVal' = Text.pack (symbolVal (Proxy @name)) + +instance (IsNamed name, SingI v) => IsNamed (Versioned (v :: Version) name) where + nameVal' = versionText (demote @v) <> "-" <> nameVal @name + +class FederationMonad (fedM :: Component -> Type -> Type) where + fedClientWithProxy :: + forall (comp :: Component) name api. + ( HasClient (fedM comp) api, + HasFedEndpoint comp api name, + KnownComponent comp, + IsNamed name, + Typeable (Client (fedM comp) api) + ) => + Proxy name -> + Proxy api -> + Proxy (fedM comp) -> + Client (fedM comp) api + +instance FederationMonad FederatorClient where + fedClientWithProxy _ = clientIn + -- | Return a client for a named endpoint. -- -- This function introduces an 'AddAnnotation' constraint, which is @@ -81,15 +116,18 @@ type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi com -- 'Wire.API.MakesFederatedCall.exposeAnnotations' for a better understanding -- of the information flow here. fedClient :: - forall (comp :: Component) name m (showcomp :: Symbol) api x. + forall (comp :: Component) name fedM (showcomp :: Symbol) api x. ( AddAnnotation 'Remote showcomp (FedPath name) x, showcomp ~ ShowComponent comp, HasFedEndpoint comp api name, - HasClient m api, - m ~ FederatorClient comp + HasClient (fedM comp) api, + KnownComponent comp, + IsNamed name, + FederationMonad fedM, + Typeable (Client (fedM comp) api) ) => - Client m api -fedClient = clientIn (Proxy @api) (Proxy @m) + Client (fedM comp) api +fedClient = fedClientWithProxy (Proxy @name) (Proxy @api) (Proxy @(fedM comp)) fedClientIn :: forall (comp :: Component) (name :: Symbol) m api. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index a9055c7384b..06089028de5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -24,6 +24,7 @@ module Wire.API.Federation.Version V1Sym0, intToVersion, versionInt, + versionText, supportedVersions, VersionInfo (..), versionInfo, @@ -47,6 +48,7 @@ import Data.OpenApi qualified as S import Data.Schema import Data.Set qualified as Set import Data.Singletons.Base.TH +import Data.Text qualified as Text import Imports data Version = V0 | V1 @@ -57,6 +59,9 @@ versionInt :: Version -> Int versionInt V0 = 0 versionInt V1 = 1 +versionText :: Version -> Text +versionText = ("v" <>) . Text.pack . show . versionInt + intToVersion :: Int -> Maybe Version intToVersion intV = find (\v -> versionInt v == intV) [minBound ..] diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index 4718fa66ad5..4148a1d4832 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -141,7 +141,7 @@ instance ToSchema Asset where -- Note: Can be turned into a sum type with additional constructors -- for future versions. data AssetKey = AssetKeyV3 AssetId AssetRetention - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform AssetKey) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetKey) @@ -321,7 +321,7 @@ data AssetRetention | -- | The asset is retained for an extended period of time, -- but not indefinitely. AssetExpiring - deriving stock (Eq, Show, Enum, Bounded, Generic) + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) deriving (Arbitrary) via (GenericUniform AssetRetention) deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AssetRetention) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 0cd23b3c3e3..f81d8f1a399 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -155,7 +155,7 @@ type UserAPI = ( Summary "Get a user by UserId" :> MakesFederatedCall 'Brig "get-users-by-ids" :> Until 'V2 - :> ZUser + :> ZLocalUser :> "users" :> CaptureUserId "uid" :> GetUserVerb @@ -166,7 +166,7 @@ type UserAPI = "get-user-qualified" ( Summary "Get a user by Domain and UserId" :> MakesFederatedCall 'Brig "get-users-by-ids" - :> ZUser + :> ZLocalUser :> "users" :> QualifiedCaptureUserId "uid" :> GetUserVerb diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index e51b6949746..f74380e1dd0 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -44,6 +44,7 @@ module Wire.API.User scimExternalId, ssoIssuerAndNameId, mkUserProfile, + mkUserProfileWithEmail, userObjectSchema, -- * NewUser @@ -793,7 +794,8 @@ data EmailVisibility a EmailVisibleIfOnSameTeam a | -- | Show your email only to yourself EmailVisibleToSelf - deriving (Eq, Show) + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving (Arbitrary) via (GenericUniform (EmailVisibility a)) type EmailVisibilityConfig = EmailVisibility () @@ -806,6 +808,26 @@ instance FromJSON (EmailVisibility ()) where "visible_to_self" -> pure EmailVisibleToSelf _ -> fail "unexpected value for EmailVisibility settings" +mkUserProfileWithEmail :: Maybe Email -> User -> UserLegalHoldStatus -> UserProfile +mkUserProfileWithEmail memail u legalHoldStatus = + -- This profile would be visible to any other user. When a new field is + -- added, please make sure it is OK for other users to have access to it. + UserProfile + { profileQualifiedId = userQualifiedId u, + profileHandle = userHandle u, + profileName = userDisplayName u, + profilePict = userPict u, + profileAssets = userAssets u, + profileAccentId = userAccentId u, + profileService = userService u, + profileDeleted = userDeleted u, + profileExpire = userExpire u, + profileTeam = userTeam u, + profileEmail = memail, + profileLegalholdStatus = legalHoldStatus, + profileSupportedProtocols = userSupportedProtocols u + } + mkUserProfile :: EmailVisibilityConfigWithViewer -> User -> UserLegalHoldStatus -> UserProfile mkUserProfile emailVisibilityConfigAndViewer u legalHoldStatus = let isEmailVisible = case emailVisibilityConfigAndViewer of @@ -815,23 +837,7 @@ mkUserProfile emailVisibilityConfigAndViewer u legalHoldStatus = EmailVisibleIfOnSameTeam (Just (viewerTeamId, viewerMembership)) -> Just viewerTeamId == userTeam u && TeamMember.hasPermission viewerMembership TeamMember.ViewSameTeamEmails - in -- This profile would be visible to any other user. When a new field is - -- added, please make sure it is OK for other users to have access to it. - UserProfile - { profileQualifiedId = userQualifiedId u, - profileHandle = userHandle u, - profileName = userDisplayName u, - profilePict = userPict u, - profileAssets = userAssets u, - profileAccentId = userAccentId u, - profileService = userService u, - profileDeleted = userDeleted u, - profileExpire = userExpire u, - profileTeam = userTeam u, - profileEmail = if isEmailVisible then userEmail u else Nothing, - profileLegalholdStatus = legalHoldStatus, - profileSupportedProtocols = userSupportedProtocols u - } + in mkUserProfileWithEmail (if isEmailVisible then userEmail u else Nothing) u legalHoldStatus -------------------------------------------------------------------------------- -- NewUser @@ -1862,7 +1868,7 @@ data AccountStatus -- allowing scim to find users that have not accepted their invitation yet after -- creating via scim. PendingInvitation - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform AccountStatus) deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema AccountStatus diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 88435e20602..217c55d5864 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -74,6 +74,7 @@ import Data.Text.Lazy qualified as LT import Data.Time.Clock import Data.Tuple.Extra (fst3, snd3, thd3) import Imports +import SAML2.WebSSO (UserRef (..)) import SAML2.WebSSO.Test.Arbitrary () import SAML2.WebSSO.Types qualified as SAML import SAML2.WebSSO.Types.Email qualified as SAMLEmail @@ -342,6 +343,18 @@ instance C.Cql UserSSOId where toCql = C.toCql . decodeUtf8With lenientDecode . toStrict . A.encode +instance Ord UserSSOId where + compare (UserSSOId ref1) (UserSSOId ref2) = ref1 `ordUserRef` ref2 + compare (UserSSOId _) (UserScimExternalId _) = LT + compare (UserScimExternalId _) (UserSSOId _) = GT + compare (UserScimExternalId t1) (UserScimExternalId t2) = t1 `compare` t2 + +-- FUTUREWORK(mangoiv): this should be upstreamed, there's no reason why SAML.UserRef doesn't have +-- an Ord instane, both of its constituents have one +ordUserRef :: SAML.UserRef -> SAML.UserRef -> Ordering +ordUserRef (UserRef tenant1 subject1) (UserRef tenant2 subject2) = + compare tenant1 tenant2 <> compare subject1 subject2 + -- | FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id -- but this is currently not possible to derive in swagger2 -- Maybe this becomes possible with swagger 3? diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index dafefa4b4a1..9a5e06883d2 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -109,7 +109,7 @@ data Asset = ImageAsset { assetKey :: AssetKey, assetSize :: Maybe AssetSize } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform Asset) deriving (FromJSON, ToJSON, S.ToSchema) via Schema Asset @@ -166,7 +166,7 @@ instance C.Cql Asset where ] data AssetSize = AssetComplete | AssetPreview - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform AssetSize) deriving (FromJSON, ToJSON, S.ToSchema) via Schema AssetSize @@ -292,7 +292,7 @@ data ManagedBy -- There are some other things that SCIM can't do yet, like setting accent IDs, but they -- are not essential, unlike e.g. passwords. ManagedByScim - deriving stock (Eq, Bounded, Enum, Show, Generic) + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (Arbitrary) via (GenericUniform ManagedBy) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ManagedBy) @@ -333,7 +333,7 @@ defaultManagedBy = ManagedByWire -- | DEPRECATED newtype Pict = Pict {fromPict :: [A.Object]} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (FromJSON, ToJSON, S.ToSchema) via Schema Pict instance ToSchema Pict where diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index dc35149eb50..7d5e5e02060 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -4,33 +4,62 @@ # dependencies are added or removed. { mkDerivation , aeson +, amazonka +, amazonka-core +, amazonka-sqs , async , base +, base16-bytestring , bilge , bytestring , bytestring-conversion +, cassandra-util , containers +, cql +, currency-codes +, data-default +, errors , exceptions , extended +, extra , gitignoreSource , gundeck-types +, HsOpenSSL , hspec , hspec-discover , http-client , http-types +, http2-manager , imports +, iso639 , lens , lib +, mime +, mime-mail +, network-conduit-tls , polysemy +, polysemy-plugin +, polysemy-time , polysemy-wire-zoo , QuickCheck , quickcheck-instances +, resourcet , retry +, servant +, servant-client-core +, stomp-queue , string-conversions , text +, time , tinylog +, transformers +, transitive-anns , types-common +, unliftio +, uuid +, wai-utilities , wire-api +, wire-api-federation }: mkDerivation { pname = "wire-subsystems"; @@ -38,26 +67,57 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ aeson + amazonka + amazonka-core + amazonka-sqs async base + base16-bytestring bilge + bytestring bytestring-conversion + cassandra-util containers + cql + currency-codes + data-default + errors exceptions extended + extra gundeck-types + HsOpenSSL + hspec http-client http-types + http2-manager imports + iso639 lens + mime + mime-mail + network-conduit-tls polysemy + polysemy-plugin + polysemy-time polysemy-wire-zoo QuickCheck + resourcet retry + servant + servant-client-core + stomp-queue text + time tinylog + transformers + transitive-anns types-common + unliftio + uuid + wai-utilities wire-api + wire-api-federation ]; testHaskellDepends = [ aeson @@ -66,17 +126,25 @@ mkDerivation { bilge bytestring containers + data-default extended gundeck-types hspec imports + iso639 polysemy + polysemy-plugin + polysemy-time polysemy-wire-zoo QuickCheck quickcheck-instances + servant-client-core string-conversions + time + transformers types-common wire-api + wire-api-federation ]; testToolDepends = [ hspec-discover ]; license = lib.licenses.agpl3Only; diff --git a/libs/wire-subsystems/src/Wire/DeleteQueue.hs b/libs/wire-subsystems/src/Wire/DeleteQueue.hs new file mode 100644 index 00000000000..f89c3eaab8e --- /dev/null +++ b/libs/wire-subsystems/src/Wire/DeleteQueue.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.DeleteQueue where + +import Data.Id +import Imports +import Polysemy + +data DeleteQueue m a where + EnqueueUserDeletion :: UserId -> DeleteQueue m () + EnqueueClientDeletion :: ClientId -> UserId -> Maybe ConnId -> DeleteQueue m () + EnqueueServiceDeletion :: ProviderId -> ServiceId -> DeleteQueue m () + +makeSem ''DeleteQueue diff --git a/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs b/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs new file mode 100644 index 00000000000..cd9400c7f54 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/DeleteQueue/InMemory.hs @@ -0,0 +1,13 @@ +module Wire.DeleteQueue.InMemory where + +import Imports +import Polysemy +import Polysemy.State +import Wire.DeleteQueue +import Wire.InternalEvent + +inMemoryDeleteQueueInterpreter :: Member (State [InternalNotification]) r => InterpreterFor DeleteQueue r +inMemoryDeleteQueueInterpreter = interpret $ \case + EnqueueUserDeletion uid -> modify (\l -> DeleteUser uid : l) + EnqueueClientDeletion cid uid mConnId -> modify (\l -> DeleteClient cid uid mConnId : l) + EnqueueServiceDeletion pid sid -> modify (\l -> DeleteService pid sid : l) diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs new file mode 100644 index 00000000000..9065f9f8c3b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/FederationAPIAccess.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.FederationAPIAccess where + +import Data.Kind +import Data.Qualified +import Imports +import Polysemy +import Polysemy.Error +import Wire.API.Federation.Component +import Wire.API.Federation.Error + +data FederationAPIAccess (fedM :: Component -> Type -> Type) m a where + RunFederatedEither :: + KnownComponent c => + Remote x -> + fedM c a -> + FederationAPIAccess fedM m (Either FederationError a) + RunFederatedConcurrently :: + forall (c :: Component) f a m x fedM. + (KnownComponent c, Foldable f) => + f (Remote x) -> + (Remote x -> fedM c a) -> + FederationAPIAccess fedM m [Either (Remote x, FederationError) (Remote a)] + -- | An action similar to 'RunFederatedConcurrently', but the input is + -- bucketed by domain before the RPCs are sent to the remote backends. + RunFederatedBucketed :: + forall (c :: Component) f a m x fedM. + (KnownComponent c, Foldable f, Functor f) => + f (Remote x) -> + (Remote [x] -> fedM c a) -> + FederationAPIAccess fedM m [Either (Remote [x], FederationError) (Remote a)] + IsFederationConfigured :: FederationAPIAccess fedM m Bool + +makeSem ''FederationAPIAccess + +runFederated :: + forall c fedM x a r. + ( Member (FederationAPIAccess fedM) r, + Member (Error FederationError) r, + KnownComponent c + ) => + Remote x -> + fedM c a -> + Sem r a +runFederated rx c = runFederatedEither rx c >>= fromEither diff --git a/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs b/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs new file mode 100644 index 00000000000..8520f11ff69 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/FederationAPIAccess/Interpreter.hs @@ -0,0 +1,93 @@ +module Wire.FederationAPIAccess.Interpreter where + +import Data.Bifunctor (first) +import Data.Domain +import Data.Id +import Data.Qualified +import HTTP2.Client.Manager +import Imports +import Polysemy +import Util.Options +import Wire.API.Federation.Client +import Wire.API.Federation.Error +import Wire.FederationAPIAccess (FederationAPIAccess (..)) +import Wire.Sem.Concurrency + +data FederationAPIAccessConfig = FederationAPIAccessConfig + { ownDomain :: Domain, + federatorEndpoint :: Maybe Endpoint, + http2Manager :: Http2Manager, + requestId :: RequestId + } + +type FederatedActionRunner fedM r = forall c x. Domain -> fedM c x -> Sem r (Either FederationError x) + +interpretFederationAPIAccess :: + forall r. + (Member (Embed IO) r, Member (Concurrency 'Unsafe) r) => + FederationAPIAccessConfig -> + InterpreterFor (FederationAPIAccess FederatorClient) r +interpretFederationAPIAccess config action = do + let isFederationConfigured = isJust config.federatorEndpoint + runner :: FederatedActionRunner FederatorClient r + runner remoteDomain rpc = + case config.federatorEndpoint of + Nothing -> pure (Left FederationNotConfigured) + Just fedEndpoint -> do + let ce = + FederatorClientEnv + { ceOriginDomain = config.ownDomain, + ceTargetDomain = remoteDomain, + ceFederator = fedEndpoint, + ceHttp2Manager = config.http2Manager, + ceOriginRequestId = config.requestId + } + embed . fmap (first FederationCallFailure) $ runFederatorClient ce rpc + interpretFederationAPIAccessGeneral runner (pure isFederationConfigured) action + +interpretFederationAPIAccessGeneral :: + forall fedM r. + (Member (Concurrency 'Unsafe) r) => + FederatedActionRunner fedM r -> + (Sem r Bool) -> + InterpreterFor (FederationAPIAccess fedM) r +interpretFederationAPIAccessGeneral runFedM isFederationConfigured = + interpret $ + \case + RunFederatedEither remote rpc -> runFederatedEither runFedM remote rpc + RunFederatedConcurrently remotes rpc -> runFederatedConcurrently runFedM remotes rpc + RunFederatedBucketed remotes rpc -> runFederatedBucketed runFedM remotes rpc + IsFederationConfigured -> isFederationConfigured + +runFederatedEither :: + FederatedActionRunner fedM r -> + Remote a -> + fedM c b -> + Sem r (Either FederationError b) +runFederatedEither runFedM (tDomain -> remoteDomain) rpc = + runFedM remoteDomain rpc + +runFederatedConcurrently :: + ( Foldable f, + Member (Concurrency 'Unsafe) r + ) => + FederatedActionRunner fedM r -> + f (Remote a) -> + (Remote a -> fedM c b) -> + Sem r [Either (Remote a, FederationError) (Remote b)] +runFederatedConcurrently runFedM xs rpc = + unsafePooledForConcurrentlyN 8 (toList xs) $ \r -> + bimap (r,) (qualifyAs r) <$> runFederatedEither runFedM r (rpc r) + +runFederatedBucketed :: + ( Foldable f, + Functor f, + Member (Concurrency 'Unsafe) r + ) => + FederatedActionRunner fedM r -> + f (Remote a) -> + (Remote [a] -> fedM c b) -> + Sem r [Either (Remote [a], FederationError) (Remote b)] +runFederatedBucketed runFedM xs rpc = + unsafePooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + bimap (r,) (qualifyAs r) <$> runFederatedEither runFedM r (rpc r) diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs similarity index 72% rename from services/brig/src/Brig/Effects/GalleyProvider.hs rename to libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 24843dbaa0b..09222ca2261 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -16,10 +16,8 @@ -- with this program. If not, see . {-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.GalleyProvider where +module Wire.GalleyAPIAccess where -import Brig.API.Types -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) @@ -36,90 +34,93 @@ import Wire.API.Team.Member qualified as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility +data ShowOrHideInvitationUrl = ShowInvitationUrl | HideInvitationUrl + deriving (Eq, Show) + data MLSOneToOneEstablished = Established | NotEstablished | NotAMember deriving (Eq, Show) -data GalleyProvider m a where +data GalleyAPIAccess m a where CreateSelfConv :: UserId -> - GalleyProvider m () + GalleyAPIAccess m () GetConv :: UserId -> Local ConvId -> - GalleyProvider m (Maybe Conversation) + GalleyAPIAccess m (Maybe Conversation) GetTeamConv :: UserId -> TeamId -> ConvId -> - GalleyProvider m (Maybe Conv.TeamConversation) + GalleyAPIAccess m (Maybe Conv.TeamConversation) NewClient :: UserId -> ClientId -> - GalleyProvider m () + GalleyAPIAccess m () CheckUserCanJoinTeam :: TeamId -> - GalleyProvider m (Maybe Wai.Error) + GalleyAPIAccess m (Maybe Wai.Error) AddTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Role) -> - GalleyProvider m Bool + GalleyAPIAccess m Bool CreateTeam :: UserId -> BindingNewTeam -> TeamId -> - GalleyProvider m CreateUserTeam + GalleyAPIAccess m () GetTeamMember :: UserId -> TeamId -> - GalleyProvider m (Maybe Team.TeamMember) + GalleyAPIAccess m (Maybe Team.TeamMember) GetTeamMembers :: TeamId -> - GalleyProvider m Team.TeamMemberList + GalleyAPIAccess m Team.TeamMemberList GetTeamId :: UserId -> - GalleyProvider m (Maybe TeamId) + GalleyAPIAccess m (Maybe TeamId) GetTeam :: TeamId -> - GalleyProvider m Team.TeamData + GalleyAPIAccess m Team.TeamData GetTeamName :: TeamId -> - GalleyProvider m Team.TeamName + GalleyAPIAccess m Team.TeamName GetTeamLegalHoldStatus :: TeamId -> - GalleyProvider m (WithStatus LegalholdConfig) + GalleyAPIAccess m (WithStatus LegalholdConfig) GetTeamSearchVisibility :: TeamId -> - GalleyProvider m TeamSearchVisibility + GalleyAPIAccess m TeamSearchVisibility ChangeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> - GalleyProvider m () + GalleyAPIAccess m () MemberIsTeamOwner :: TeamId -> UserId -> - GalleyProvider m Bool + GalleyAPIAccess m Bool GetAllFeatureConfigsForUser :: Maybe UserId -> - GalleyProvider m AllFeatureConfigs + GalleyAPIAccess m AllFeatureConfigs GetVerificationCodeEnabled :: TeamId -> - GalleyProvider m Bool + GalleyAPIAccess m Bool GetExposeInvitationURLsToTeamAdmin :: TeamId -> - GalleyProvider m ShowOrHideInvitationUrl + GalleyAPIAccess m ShowOrHideInvitationUrl IsMLSOne2OneEstablished :: Local UserId -> Qualified UserId -> - GalleyProvider m MLSOneToOneEstablished + GalleyAPIAccess m MLSOneToOneEstablished UnblockConversation :: Local UserId -> Maybe ConnId -> Qualified ConvId -> - GalleyProvider m Conversation + GalleyAPIAccess m Conversation -makeSem ''GalleyProvider +makeSem ''GalleyAPIAccess diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs similarity index 93% rename from services/brig/src/Brig/Effects/GalleyProvider/RPC.hs rename to libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 08759ee2b06..8363fcaf4a2 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -15,15 +15,9 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Effects.GalleyProvider.RPC where +module Wire.GalleyAPIAccess.Rpc where import Bilge hiding (head, options, requestId) -import Brig.API.Types -import Brig.Effects.GalleyProvider (GalleyProvider (..), MLSOneToOneEstablished (..)) -import Brig.RPC hiding (galleyRequest) -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) -import Control.Error (hush) -import Control.Lens ((^.)) import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as BL @@ -32,7 +26,6 @@ import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) import Data.Qualified -import Data.Range import Imports import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types qualified as HTTP @@ -44,7 +37,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Servant.API (toHeader) -import System.Logger (field, msg, val) +import System.Logger.Message import Util.Options import Wire.API.Conversation hiding (Member) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team @@ -55,18 +48,20 @@ import Wire.API.Team.Feature import Wire.API.Team.Member as Member import Wire.API.Team.Role import Wire.API.Team.SearchVisibility +import Wire.GalleyAPIAccess (GalleyAPIAccess (..), MLSOneToOneEstablished (..), ShowOrHideInvitationUrl (..)) +import Wire.ParseException import Wire.Rpc -interpretGalleyProviderToRpc :: +interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, Member TinyLog r ) => Set Version -> Endpoint -> - Sem (GalleyProvider ': r) a -> + Sem (GalleyAPIAccess ': r) a -> Sem r a -interpretGalleyProviderToRpc disabledVersions galleyEndpoint = +interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = let v = fromMaybe (error "service can't run with undefined API version") $ maxAvailableVersion disabledVersions in interpret $ runInputConst galleyEndpoint . \case @@ -220,7 +215,7 @@ checkUserCanJoinTeam tid = do rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> Nothing - _ -> case decodeBodyMaybe "galley" rs of + _ -> case responseJsonMaybe rs of Just (e :: Wai.Error) -> pure e Nothing -> error ("Invalid response from galley: " <> show rs) where @@ -267,17 +262,12 @@ createTeam :: UserId -> BindingNewTeam -> TeamId -> - Sem r CreateUserTeam -createTeam u t@(BindingNewTeam bt) teamid = do + Sem r () +createTeam u t teamid = do debug $ remote "galley" . msg (val "Creating Team") - r <- galleyRequest $ req teamid - tid <- - maybe (error "invalid team id") pure $ - fromByteString $ - getHeader' "Location" r - pure (CreateUserTeam tid $ fromRange (bt ^. newTeamName)) + void $ galleyRequest $ req teamid where req tid = method PUT @@ -462,16 +452,7 @@ getVerificationCodeEnabled tid = do . expect2xx decodeBodyOrThrow :: forall a r. (Typeable a, FromJSON a, Member (Error ParseException) r) => Text -> Response (Maybe BL.ByteString) -> Sem r a -decodeBodyOrThrow t r = - case decodeBody @a t r of - Left a -> - case Imports.fromException a of - Just pe -> throw @ParseException pe - Nothing -> error "impossible: something other than ParseExceptionNothing was thrown by decodeBody" - Right b -> pure b - -decodeBodyMaybe :: (Typeable a, FromJSON a) => Text -> Response (Maybe BL.ByteString) -> Maybe a -decodeBodyMaybe t r = hush $ decodeBody t r +decodeBodyOrThrow ctx r = either (throw . ParseException ctx) pure (responseJsonEither r) getAllFeatureConfigsForUser :: (Member Rpc r, Member (Input Endpoint) r) => @@ -590,3 +571,6 @@ unblockConversation v lusr mconn (Qualified cnv cdom) = do . paths [toHeader v, "conversations", toByteString' cdom, toByteString' cnv] . zUser (tUnqualified lusr) . expect2xx + +remote :: ByteString -> Msg -> Msg +remote = field "remote" diff --git a/libs/wire-subsystems/src/Wire/InternalEvent.hs b/libs/wire-subsystems/src/Wire/InternalEvent.hs new file mode 100644 index 00000000000..3dbe7e19358 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/InternalEvent.hs @@ -0,0 +1,83 @@ +-- 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 Wire.InternalEvent + ( InternalNotification (..), + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Id +import Imports + +data InternalNotification + = DeleteClient !ClientId !UserId !(Maybe ConnId) + | DeleteUser !UserId + | DeleteService !ProviderId !ServiceId + deriving (Eq, Show) + +data InternalNotificationType + = ClientDeletion + | UserDeletion + | ServiceDeletion + deriving (Eq, Show) + +instance FromJSON InternalNotificationType where + parseJSON = \case + "client.delete" -> pure ClientDeletion + "user.delete" -> pure UserDeletion + "service.delete" -> pure ServiceDeletion + x -> fail $ "InternalNotificationType: Unknown type " <> show x + +instance ToJSON InternalNotificationType where + toJSON ClientDeletion = "client.delete" + toJSON UserDeletion = "user.delete" + toJSON ServiceDeletion = "service.delete" + +instance FromJSON InternalNotification where + parseJSON = withObject "InternalNotification" $ \o -> do + t <- o .: "type" + case (t :: InternalNotificationType) of + ClientDeletion -> DeleteClient <$> (adaptOldFormat =<< (o .: "client")) <*> o .: "user" <*> o .: "connection" + UserDeletion -> DeleteUser <$> o .: "user" + ServiceDeletion -> DeleteService <$> o .: "provider" <*> o .: "service" + where + adaptOldFormat :: Value -> Parser ClientId + adaptOldFormat (Object ob) = ob .: "id" + adaptOldFormat v@(String _) = parseJSON v + adaptOldFormat _ = fail "adaptOld: " + +instance ToJSON InternalNotification where + toJSON (DeleteClient c uid con) = + object + [ "client" .= c, + "user" .= uid, + "connection" .= con, + "type" .= ClientDeletion + ] + toJSON (DeleteUser uid) = + object + [ "user" .= uid, + "type" .= UserDeletion + ] + toJSON (DeleteService pid sid) = + object + [ "provider" .= pid, + "service" .= sid, + "type" .= ServiceDeletion + ] diff --git a/libs/wire-subsystems/src/Wire/MiniBackend.hs b/libs/wire-subsystems/src/Wire/MiniBackend.hs new file mode 100644 index 00000000000..9ff7e22e0b3 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/MiniBackend.hs @@ -0,0 +1,288 @@ +module Wire.MiniBackend where + +import Data.Default (Default (def)) +import Data.Domain +import Data.Id +import Data.LanguageCodes (ISO639_1 (EN)) +import Data.LegalHold (defUserLegalHoldStatus) +import Data.Map.Lazy qualified as LM +import Data.Map.Strict qualified as M +import Data.Proxy +import Data.Qualified +import Data.Set qualified as S +import Data.Time +import Data.Type.Equality +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import Servant.Client.Core +import Test.QuickCheck +import Type.Reflection +import Wire.API.Federation.API +import Wire.API.Federation.Component +import Wire.API.Federation.Error +import Wire.API.Team.Member +import Wire.API.User hiding (DeleteUser) +import Wire.DeleteQueue +import Wire.DeleteQueue.InMemory +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess.Interpreter as FI +import Wire.GalleyAPIAccess +import Wire.InternalEvent +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.Sequential +import Wire.Sem.Now +import Wire.StoredUser +import Wire.UserStore +import Wire.UserSubsystem +import Wire.UserSubsystem.Interpreter + +newtype PendingStoredUser = PendingStoredUser StoredUser + deriving (Show, Eq) + +instance Arbitrary PendingStoredUser where + arbitrary = do + user <- arbitrary + pure $ PendingStoredUser (user {status = Just PendingInvitation}) + +newtype NotPendingStoredUser = NotPendingStoredUser StoredUser + deriving (Show, Eq) + +instance Arbitrary NotPendingStoredUser where + arbitrary = do + user <- arbitrary + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) + pure $ NotPendingStoredUser (user {status = notPendingStatus}) + +type GetUserProfileEffects = + [ UserSubsystem, + GalleyAPIAccess, + UserStore, + DeleteQueue, + State [InternalNotification], + Now, + Input UserSubsystemConfig, + FederationAPIAccess MiniFederationMonad, + Concurrency 'Unsafe, + Error FederationError + ] + +-- | a type representing the state of a single backend +data MiniBackend = MkMiniBackend + { -- | this is morally the same as the users stored in the actual backend + -- invariant: for each key, the user.id and the key are the same + users :: Set StoredUser + } + +instance Default MiniBackend where + def = MkMiniBackend {users = mempty} + +-- | represents an entire federated, stateful world of backends +newtype MiniFederation = MkMiniFederation + { -- | represents the state of the backends, mapped from their domains + backends :: Map Domain MiniBackend + } + +data MiniContext = MkMiniContext + { -- | the domain that is receiving the request + ownDomain :: Domain + } + +newtype MiniFederationMonad comp a = MkMiniFederationMonad + {unMiniFederation :: Sem [Input MiniContext, State MiniFederation] a} + deriving newtype (Functor, Applicative, Monad) + +instance RunClient (MiniFederationMonad comp) where + runRequestAcceptStatus _acceptableStatuses _req = error "MiniFederation does not support servant client" + throwClientError _err = error "MiniFederation does not support servant client" + +data SubsystemOperationList where + TNil :: SubsystemOperationList + (:::) :: Typeable a => (Component, Text, a) -> SubsystemOperationList -> SubsystemOperationList + +infixr 5 ::: + +lookupSubsystemOperation :: + Typeable a => + -- | The type to compare to + (Component, Text, Proxy a) -> + -- | what to return when none of the types match + a -> + -- | the types to try + SubsystemOperationList -> + a +lookupSubsystemOperation goal@(goalComp, goalRoute, Proxy @goalType) a = \case + TNil -> a + (comp, route, client) ::: xs -> case eqTypeRep (typeRep @goalType) (typeOf client) of + Just HRefl | comp == goalComp && route == goalRoute -> client + _ -> lookupSubsystemOperation goal a xs + +instance FederationMonad MiniFederationMonad where + fedClientWithProxy (Proxy @name) (Proxy @api) (_ :: Proxy (MiniFederationMonad comp)) = + lookupSubsystemOperation + (componentVal @comp, nameVal @name, Proxy @(Client (MiniFederationMonad comp) api)) + do + error + "The testsuite has evaluated a tuple of component, route and client that is\ + \ not covered by the MiniFederation implementation of FederationMonad" + do + (Brig, "get-users-by-ids", miniGetUsersByIds) + ::: (Brig, "get-user-by-id", miniGetUserById) + ::: TNil + +miniLocale :: Locale +miniLocale = + Locale + { lLanguage = Language EN, + lCountry = Nothing + } + +-- | runs a stateful backend, returns the state and puts it back into the +-- federated global state +runOnOwnBackend :: Sem '[Input Domain, State MiniBackend] a -> MiniFederationMonad comp a +runOnOwnBackend = MkMiniFederationMonad . runOnOwnBackend' . subsume_ + +-- | Runs action in the context of a single backend, without access to others. +runOnOwnBackend' :: + (Member (Input MiniContext) r, Member (State MiniFederation) r) => + Sem (Input Domain ': State MiniBackend ': r) a -> + Sem r a +runOnOwnBackend' act = do + ownDomain <- inputs (.ownDomain) + ownBackend <- + fromMaybe (error "tried to lookup domain that is not part of the backends' state") + <$> gets (M.lookup ownDomain . backends) + (newBackend, res) <- runState ownBackend $ runInputConst ownDomain act + modify (\minifed -> minifed {backends = M.insert ownDomain newBackend (minifed.backends)}) + pure res + +miniGetAllProfiles :: + (Member (Input Domain) r, Member (State MiniBackend) r) => + Sem r [UserProfile] +miniGetAllProfiles = do + users <- gets (.users) + dom <- input + pure $ + map + (\u -> mkUserProfileWithEmail Nothing (mkUserFromStored dom miniLocale u) defUserLegalHoldStatus) + (S.toList users) + +miniGetUsersByIds :: [UserId] -> MiniFederationMonad 'Brig [UserProfile] +miniGetUsersByIds userIds = runOnOwnBackend do + usersById :: LM.Map UserId UserProfile <- + M.fromList . map (\user -> (user.profileQualifiedId.qUnqualified, user)) <$> miniGetAllProfiles + pure $ mapMaybe (flip M.lookup usersById) userIds + +miniGetUserById :: UserId -> MiniFederationMonad 'Brig (Maybe UserProfile) +miniGetUserById uid = + runOnOwnBackend $ + find (\u -> u.profileQualifiedId.qUnqualified == uid) <$> miniGetAllProfiles + +runMiniFederation :: Domain -> Map Domain MiniBackend -> MiniFederationMonad c a -> a +runMiniFederation ownDomain backends = + run + . evalState MkMiniFederation {backends = backends} + . runInputConst MkMiniContext {ownDomain = ownDomain} + . unMiniFederation + +interpretNowConst :: + UTCTime -> + Sem (Now : r) a -> + Sem r a +interpretNowConst time = interpret \case + Wire.Sem.Now.Get -> pure time + +runFederationStack :: + [StoredUser] -> + Map Domain MiniBackend -> + Maybe TeamMember -> + UserSubsystemConfig -> + Sem GetUserProfileEffects a -> + a +runFederationStack allLocalUsers fedBackends teamMember cfg = + let unsafeError e = error $ "Unexpected error: " <> displayException e + in either unsafeError Imports.id + . runFederationStackEither + allLocalUsers + fedBackends + teamMember + cfg + +runFederationStackEither :: + [StoredUser] -> + -- | the available backend + Map Domain MiniBackend -> + Maybe TeamMember -> + UserSubsystemConfig -> + Sem GetUserProfileEffects a -> + Either FederationError a +runFederationStackEither allLocalUsers backends teamMember cfg = + run + . runError + . sequentiallyPerformConcurrency + . miniFederationAPIAccess backends + . runInputConst cfg + . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) + . evalState [] + . inMemoryDeleteQueueInterpreter + . staticUserStoreInterpreter allLocalUsers + . miniGalleyAPIAccess teamMember + . runUserSubsystem cfg + +runNoFederationStack :: + [StoredUser] -> + Maybe TeamMember -> + UserSubsystemConfig -> + Sem GetUserProfileEffects a -> + a +runNoFederationStack allUsers teamMember cfg = + run + . runErrorUnsafe + . sequentiallyPerformConcurrency + . emptyFederationAPIAcesss + . runInputConst cfg + . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) + . evalState [] + . inMemoryDeleteQueueInterpreter + . staticUserStoreInterpreter allUsers + . miniGalleyAPIAccess teamMember + . runUserSubsystem cfg + +runErrorUnsafe :: Exception e => InterpreterFor (Error e) r +runErrorUnsafe action = do + res <- runError action + case res of + Left e -> error $ "Unexpected error: " <> displayException e + Right x -> pure x + +emptyFederationAPIAcesss :: InterpreterFor (FederationAPIAccess MiniFederationMonad) r +emptyFederationAPIAcesss = interpret $ \case + _ -> error "uninterpreted effect: FederationAPIAccess" + +miniFederationAPIAccess :: + forall a r. + Map Domain MiniBackend -> + Sem (FederationAPIAccess MiniFederationMonad : r) a -> + Sem r a +miniFederationAPIAccess online = do + let runner :: FederatedActionRunner MiniFederationMonad r + runner domain rpc = pure . Right $ runMiniFederation domain online rpc + interpret \case + RunFederatedEither remote rpc -> + if isJust (M.lookup (qDomain $ tUntagged remote) online) + then FI.runFederatedEither runner remote rpc + else pure $ Left do FederationUnexpectedError "RunFederatedEither" + RunFederatedConcurrently _remotes _rpc -> error "unimplemented: RunFederatedConcurrently" + RunFederatedBucketed _domain _rpc -> error "unimplemented: RunFederatedBucketed" + IsFederationConfigured -> pure True + +staticUserStoreInterpreter :: [StoredUser] -> InterpreterFor UserStore r +staticUserStoreInterpreter allUsers = interpret $ \case + GetUser uid -> pure $ find (\user -> user.id == uid) allUsers + +miniGalleyAPIAccess :: Maybe TeamMember -> InterpreterFor GalleyAPIAccess r +miniGalleyAPIAccess member = interpret $ \case + GetTeamMember _ _ -> pure member + _ -> error "uninterpreted effect: GalleyAPIAccess" diff --git a/libs/wire-subsystems/src/Wire/ParseException.hs b/libs/wire-subsystems/src/Wire/ParseException.hs new file mode 100644 index 00000000000..41d55528071 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ParseException.hs @@ -0,0 +1,18 @@ +module Wire.ParseException where + +import Data.Text qualified as Text +import Imports + +-- | Failed to parse a response from another service. +data ParseException = ParseException + { _parseExceptionRemote :: !Text, + _parseExceptionMsg :: String + } + deriving stock (Eq, Ord, Show) + +instance Exception ParseException where + displayException (ParseException r m) = + "Failed to parse response from remote " + ++ Text.unpack r + ++ " with message: " + ++ m diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs new file mode 100644 index 00000000000..b6fb20cb073 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.StoredUser where + +import Data.Domain +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Qualified +import Database.CQL.Protocol (Record (..), TupleType, recordInstance) +import Imports +import Wire.API.Provider.Service +import Wire.API.User +import Wire.Arbitrary + +data StoredUser = StoredUser + { id :: UserId, + name :: Name, + pict :: Maybe Pict, + email :: Maybe Email, + phone :: Maybe Phone, + ssoId :: Maybe UserSSOId, + accentId :: ColourId, + assets :: Maybe [Asset], + activated :: Bool, + status :: Maybe AccountStatus, + expires :: Maybe UTCTimeMillis, + language :: Maybe Language, + country :: Maybe Country, + providerId :: Maybe ProviderId, + serviceId :: Maybe ServiceId, + handle :: Maybe Handle, + teamId :: Maybe TeamId, + managedBy :: Maybe ManagedBy, + supportedProtocols :: Maybe (Set BaseProtocolTag) + } + deriving (Show, Eq, Ord, Generic) + deriving (Arbitrary) via (GenericUniform StoredUser) + +recordInstance ''StoredUser + +hasPendingInvitation :: StoredUser -> Bool +hasPendingInvitation u = u.status == Just PendingInvitation + +mkUserFromStored :: Domain -> Locale -> StoredUser -> User +mkUserFromStored domain defaultLocale storedUser = + let ident = toIdentity storedUser.activated storedUser.email storedUser.phone storedUser.ssoId + deleted = Just Deleted == storedUser.status + expiration = if storedUser.status == Just Ephemeral then storedUser.expires else Nothing + loc = toLocale defaultLocale (storedUser.language, storedUser.country) + svc = newServiceRef <$> storedUser.serviceId <*> storedUser.providerId + in User + { userQualifiedId = (Qualified storedUser.id domain), + userIdentity = ident, + userDisplayName = storedUser.name, + userPict = (fromMaybe noPict storedUser.pict), + userAssets = (fromMaybe [] storedUser.assets), + userAccentId = storedUser.accentId, + userDeleted = deleted, + userLocale = loc, + userService = svc, + userHandle = storedUser.handle, + userExpire = expiration, + userTeam = storedUser.teamId, + userManagedBy = (fromMaybe ManagedByWire storedUser.managedBy), + userSupportedProtocols = (fromMaybe defSupportedProtocols storedUser.supportedProtocols) + } + +toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale +toLocale _ (Just l, c) = Locale l c +toLocale l _ = l + +-- | If the user is not activated, 'toIdentity' will return 'Nothing' as a +-- precaution, because elsewhere we rely on the fact that a non-empty +-- 'UserIdentity' means that the user is activated. +-- +-- The reason it's just a "precaution" is that we /also/ have an invariant that +-- having an email or phone in the database means the user has to be activated. +toIdentity :: + -- | Whether the user is activated + Bool -> + Maybe Email -> + Maybe Phone -> + Maybe UserSSOId -> + Maybe UserIdentity +toIdentity True (Just e) (Just p) Nothing = Just $! FullIdentity e p +toIdentity True (Just e) Nothing Nothing = Just $! EmailIdentity e +toIdentity True Nothing (Just p) Nothing = Just $! PhoneIdentity p +toIdentity True email phone (Just ssoid) = Just $! SSOIdentity ssoid email phone +toIdentity True Nothing Nothing Nothing = Nothing +toIdentity False _ _ _ = Nothing diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs new file mode 100644 index 00000000000..7e7d689d691 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.UserStore where + +import Data.Id +import Imports +import Polysemy +import Wire.StoredUser + +data UserStore m a where + GetUser :: UserId -> UserStore m (Maybe StoredUser) + +makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs new file mode 100644 index 00000000000..c1715d0aa3d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -0,0 +1,28 @@ +module Wire.UserStore.Cassandra where + +import Cassandra +import Data.Id +import Database.CQL.Protocol +import Imports +import Polysemy +import Polysemy.Embed +import Wire.StoredUser +import Wire.UserStore + +interpretUserStoreCassandra :: Member (Embed IO) r => ClientState -> InterpreterFor UserStore r +interpretUserStoreCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + GetUser uid -> getUserImpl uid + +getUserImpl :: Member (Embed Client) r => UserId -> Sem r (Maybe StoredUser) +getUserImpl uid = embed $ do + mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) + pure $ asRecord <$> mUserTuple + +selectUser :: PrepQuery R (Identity UserId) (TupleType StoredUser) +selectUser = + "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ + \activated, status, expires, language, country, provider, service, \ + \handle, team, managed_by, supported_protocols \ + \FROM user where id = ?" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs new file mode 100644 index 00000000000..ae344ec3361 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.UserSubsystem where + +import Data.Id +import Data.Qualified +import Imports +import Polysemy +import Wire.API.Federation.Error +import Wire.API.User + +data UserSubsystem m a where + -- | First arg is for authorization only. + GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] + -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. + GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] + -- | These give us partial success and hide concurrency in the interpreter. + -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? + GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) + +makeSem ''UserSubsystem + +getUserProfile :: Member UserSubsystem r => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) +getUserProfile luid targetUser = + listToMaybe <$> getUserProfiles luid [targetUser] + +getLocalUserProfile :: Member UserSubsystem r => Local UserId -> Sem r (Maybe UserProfile) +getLocalUserProfile targetUser = + listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs new file mode 100644 index 00000000000..948d4689b24 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -0,0 +1,240 @@ +module Wire.UserSubsystem.Interpreter + ( runUserSubsystem, + UserSubsystemConfig (..), + ) +where + +import Control.Lens (view) +import Control.Monad.Trans.Maybe +import Data.Either.Extra +import Data.Id +import Data.Json.Util +import Data.LegalHold +import Data.Qualified +import Data.Time.Clock +import Imports hiding (local) +import Polysemy +import Polysemy.Error hiding (try) +import Polysemy.Input +import Servant.Client.Core +import Wire.API.Federation.API +import Wire.API.Federation.Error +import Wire.API.Team.Member +import Wire.API.User +import Wire.DeleteQueue +import Wire.FederationAPIAccess +import Wire.GalleyAPIAccess +import Wire.Sem.Concurrency +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.StoredUser +import Wire.UserStore +import Wire.UserSubsystem (UserSubsystem (..)) + +data UserSubsystemConfig = UserSubsystemConfig + { emailVisibilityConfig :: EmailVisibilityConfig, + defaultLocale :: Locale + } + +runUserSubsystem :: + ( Member GalleyAPIAccess r, + Member UserStore r, + Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. + Member (Error FederationError) r, + Member (FederationAPIAccess fedM) r, + Member DeleteQueue r, + Member Now r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + UserSubsystemConfig -> + InterpreterFor UserSubsystem r +runUserSubsystem cfg = interpret $ \case + GetUserProfiles self others -> runInputConst cfg $ getUserProfilesImpl self others + GetLocalUserProfiles others -> runInputConst cfg $ getLocalUserProfilesImpl others + GetUserProfilesWithErrors self others -> runInputConst cfg $ getUserProfilesWithErrorsImpl self others + +-- | Obtain user profiles for a list of users as they can be seen by +-- a given user 'self'. If 'self' is an unknown 'UserId', return '[]'. +getUserProfilesImpl :: + ( Member GalleyAPIAccess r, + Member (Input UserSubsystemConfig) r, + Member UserStore r, + Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. + Member (Error FederationError) r, + Member (FederationAPIAccess fedM) r, + Member DeleteQueue r, + Member Now r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + -- | User 'self' on whose behalf the profiles are requested. + Local UserId -> + -- | The users ('others') for which to obtain the profiles. + [Qualified UserId] -> + Sem r [UserProfile] +getUserProfilesImpl self others = + concat + <$> unsafePooledMapConcurrentlyN + 8 + (getUserProfilesFromDomain self) + (bucketQualified others) + +getLocalUserProfilesImpl :: + forall r. + ( Member UserStore r, + Member (Input UserSubsystemConfig) r, + Member DeleteQueue r, + Member Now r, + Member GalleyAPIAccess r + ) => + Local [UserId] -> + Sem r [UserProfile] +getLocalUserProfilesImpl = getUserProfilesLocalPart Nothing + +getUserProfilesFromDomain :: + ( Member GalleyAPIAccess r, + Member (Error FederationError) r, + Member (Input UserSubsystemConfig) r, + Member (FederationAPIAccess fedM) r, + Member DeleteQueue r, + Member Now r, + Member UserStore r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + Local UserId -> + Qualified [UserId] -> + Sem r [UserProfile] +getUserProfilesFromDomain self = + foldQualified + self + (getUserProfilesLocalPart (Just self)) + getUserProfilesRemotePart + +getUserProfilesRemotePart :: + ( Member (FederationAPIAccess fedM) r, + Member (Error FederationError) r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + Remote [UserId] -> + Sem r [UserProfile] +getUserProfilesRemotePart ruids = do + runFederated ruids $ fedClient @'Brig @"get-users-by-ids" (tUnqualified ruids) + +getUserProfilesLocalPart :: + forall r. + ( Member UserStore r, + Member (Input UserSubsystemConfig) r, + Member DeleteQueue r, + Member Now r, + Member GalleyAPIAccess r + ) => + Maybe (Local UserId) -> + Local [UserId] -> + Sem r [UserProfile] +getUserProfilesLocalPart requestingUser luids = do + emailVisibilityConfig <- inputs emailVisibilityConfig + emailVisibilityConfigWithViewer <- + case emailVisibilityConfig of + EmailVisibleIfOnTeam -> pure EmailVisibleIfOnTeam + EmailVisibleToSelf -> pure EmailVisibleToSelf + EmailVisibleIfOnSameTeam () -> + EmailVisibleIfOnSameTeam . join @Maybe + <$> traverse getRequestingUserInfo requestingUser + -- FUTUREWORK: (in the interpreters where it makes sense) pull paginated lists from the DB, + -- not just single rows. + catMaybes <$> traverse (getLocalUserProfile emailVisibilityConfigWithViewer) (sequence luids) + where + getRequestingUserInfo :: Local UserId -> Sem r (Maybe (TeamId, TeamMember)) + getRequestingUserInfo self = do + -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') + -- to return 'Nothing'. we could throw errors here if that happens, rather than just + -- returning an empty profile list from 'lookupProfiles'. + mUser <- getUser $ tUnqualified self + let mUserNotPending = do + user <- mUser + guard $ not (hasPendingInvitation user) + pure user + case mUserNotPending >>= (.teamId) of + Nothing -> pure Nothing + Just tid -> (tid,) <$$> getTeamMember (tUnqualified self) tid + +getLocalUserProfile :: + forall r. + ( Member UserStore r, + Member GalleyAPIAccess r, + Member DeleteQueue r, + Member Now r, + Member (Input UserSubsystemConfig) r + ) => + EmailVisibilityConfigWithViewer -> + Local UserId -> + Sem r (Maybe UserProfile) +getLocalUserProfile emailVisibilityConfigWithViewer luid = do + let domain = tDomain luid + locale <- inputs defaultLocale + runMaybeT $ do + storedUser <- MaybeT $ getUser (tUnqualified luid) + guard $ not (hasPendingInvitation storedUser) + lhs :: UserLegalHoldStatus <- do + teamMember <- lift $ join <$> (getTeamMember storedUser.id `mapM` storedUser.teamId) + pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) teamMember + let user = mkUserFromStored domain locale storedUser + usrProfile = mkUserProfile emailVisibilityConfigWithViewer user lhs + lift $ deleteLocalIfExpired user + pure usrProfile + +-- | ephemeral users past their expiry date are queued for deletion +deleteLocalIfExpired :: forall r. (Member DeleteQueue r, Member Now r) => User -> Sem r () +deleteLocalIfExpired user = + case user.userExpire of + Nothing -> pure () + Just (fromUTCTimeMillis -> e) -> do + t <- Now.get + when (diffUTCTime e t < 0) $ + enqueueUserDeletion (qUnqualified user.userQualifiedId) + +getUserProfilesWithErrorsImpl :: + forall r fedM. + ( Member UserStore r, + Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. + Member (Input UserSubsystemConfig) r, + Member (FederationAPIAccess fedM) r, + Member GalleyAPIAccess r, + Member DeleteQueue r, + Member Now r, + RunClient (fedM 'Brig), + FederationMonad fedM, + Typeable fedM + ) => + Local UserId -> + [Qualified UserId] -> + Sem r ([(Qualified UserId, FederationError)], [UserProfile]) +getUserProfilesWithErrorsImpl self others = do + aggregate ([], []) <$> unsafePooledMapConcurrentlyN 8 go (bucketQualified others) + where + go :: Qualified [UserId] -> Sem r (Either (FederationError, Qualified [UserId]) [UserProfile]) + go bucket = runError (getUserProfilesFromDomain self bucket) <&> mapLeft (,bucket) + -- this function will partition the Eithers into a list of pairs such that + -- - the left side will contain a list of users with a federation error 'Left's + -- - the right side will contain a list of user profiles obtained from the 'Right's + -- - the left side will have to transform a pair of error and user ids into a list + -- of users ids paired with errors; this is done by just pairing all of them with + -- the same error + aggregate :: + ( inp ~ [Either (FederationError, Qualified [UserId]) [UserProfile]], + outp ~ ([(Qualified UserId, FederationError)], [UserProfile]) + ) => + (outp -> inp -> outp) + aggregate acc [] = acc + aggregate (accL, accR) (Right prof : buckets) = aggregate (accL, prof <> accR) buckets + aggregate (accL, accR) (Left err : buckets) = aggregate (renderBucketError err <> accL, accR) buckets + + renderBucketError :: (FederationError, Qualified [UserId]) -> [(Qualified UserId, FederationError)] + renderBucketError (err, qlist) = (,err) . (flip Qualified (qDomain qlist)) <$> qUnqualified qlist diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 1b5aee83b2b..38bebcabb28 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -82,7 +82,7 @@ spec = describe "NotificationSubsystem.Interpreter" do largePush ] - (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes + (_, actualPushes) <- runMiniStack mockConfig $ pushImpl pushes let expectedPushes = map toV2Push @@ -136,7 +136,7 @@ spec = describe "NotificationSubsystem.Interpreter" do pushSmallerThanFanoutLimit ] - (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes + (_, actualPushes) <- runMiniStack mockConfig $ pushImpl pushes let expectedPushes = map toV2Push @@ -191,7 +191,7 @@ spec = describe "NotificationSubsystem.Interpreter" do delayControl <- newEmptyMVar slowPushThread <- async $ - runMockStackWithControlledDelay mockConfig delayControl actualPushesRef $ + runMiniStackWithControlledDelay mockConfig delayControl actualPushesRef $ pushSlowlyImpl pushes putMVar delayControl (diffTimeToFullMicroseconds mockConfig.slowPushDelay) @@ -229,7 +229,7 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushApsData = Nothing } pushes = [push1] - (_, attemptedPushes, logs) <- runMockStackAsync mockConfig $ do + (_, attemptedPushes, logs) <- runMiniStackAsync mockConfig $ do thread <- pushAsyncImpl pushes await thread @@ -266,8 +266,8 @@ spec = describe "NotificationSubsystem.Interpreter" do it "respects the chunkSize limit" $ property \limit pushes -> all ((<= limit) . sizeOfChunks) (chunkPushes limit pushes) -runMockStack :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]]) -runMockStack mockConfig action = do +runMiniStack :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]]) +runMiniStack mockConfig action = do actualPushesRef <- newIORef [] x <- runFinal @@ -279,8 +279,8 @@ runMockStack mockConfig action = do $ action (x,) <$> readIORef actualPushesRef -runMockStackAsync :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, P.TinyLog, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]], [(Level, LByteString)]) -runMockStackAsync mockConfig action = do +runMiniStackAsync :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, P.TinyLog, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]], [(Level, LByteString)]) +runMiniStackAsync mockConfig action = do actualPushesRef <- newIORef [] lr <- newLogRecorder x <- @@ -294,13 +294,13 @@ runMockStackAsync mockConfig action = do $ action (x,,) <$> readIORef actualPushesRef <*> readIORef lr.recordedLogs -runMockStackWithControlledDelay :: +runMiniStackWithControlledDelay :: NotificationSubsystemConfig -> MVar Int -> IORef [[V2.Push]] -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, Embed IO, Async, Final IO] a -> IO a -runMockStackWithControlledDelay mockConfig delayControl actualPushesRef = do +runMiniStackWithControlledDelay mockConfig delayControl actualPushesRef = do runFinal . asyncToIOFinal . embedToFinal @IO diff --git a/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs new file mode 100644 index 00000000000..7a4ca034831 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/UserStoreSpec.hs @@ -0,0 +1,36 @@ +module Wire.UserStoreSpec (spec) where + +import Imports +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.User +import Wire.StoredUser + +spec :: Spec +spec = do + describe "mkUserFromStored" $ do + prop "user identity" $ \domain defaultLocale storedUser -> + let user = mkUserFromStored domain defaultLocale storedUser + in if not storedUser.activated + then user.userIdentity === Nothing + else + (emailIdentity =<< user.userIdentity) === storedUser.email + .&&. (phoneIdentity =<< user.userIdentity) === storedUser.phone + .&&. (ssoIdentity =<< user.userIdentity) === storedUser.ssoId + + prop "user deleted" $ \domain defaultLocale storedUser -> + let user = mkUserFromStored domain defaultLocale storedUser + in user.userDeleted === (storedUser.status == Just Deleted) + + prop "user expires" $ \domain defaultLocale storedUser -> + let user = mkUserFromStored domain defaultLocale storedUser + in if storedUser.status == Just Ephemeral + then user.userExpire === storedUser.expires + else user.userExpire === Nothing + + prop "user locale" $ \domain defaultLocale storedUser -> + let user = mkUserFromStored domain defaultLocale storedUser + in if (isJust storedUser.language) + then user.userLocale === Locale (fromJust storedUser.language) storedUser.country + else user.userLocale === defaultLocale diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..1e2f399b658 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedLists #-} + +module Wire.UserSubsystem.InterpreterSpec (spec) where + +import Data.Bifunctor (first) +import Data.Coerce +import Data.Default (Default (def)) +import Data.Domain +import Data.Id +import Data.LegalHold (defUserLegalHoldStatus) +import Data.Qualified +import Data.Set qualified as S +import Imports +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.Federation.Error +import Wire.API.Team.Member +import Wire.API.Team.Permission +import Wire.API.User hiding (DeleteUser) +import Wire.MiniBackend +import Wire.StoredUser +import Wire.UserSubsystem +import Wire.UserSubsystem.Interpreter + +spec :: Spec +spec = describe "UserSubsystem.Interpreter" do + describe "getUserProfiles" do + describe "[with federation]" do + prop "gets all users on multiple federating backends" $ + \viewerTeam (localTargetUsersNotPending :: [NotPendingStoredUser]) targetUsers1 targetUsers2 visibility localDomain remoteDomain1 remoteDomain2 -> do + let remoteBackend1 = def {users = targetUsers1} + remoteBackend2 = def {users = targetUsers2} + viewer = viewerTeam {teamId = Nothing} + -- Having teams adds complications in email visibility, + -- all that stuff is tested in [without federation] tests + localTargetUsers = + S.fromList $ + map (\user -> (coerce user) {teamId = Nothing}) localTargetUsersNotPending + federation = [(remoteDomain1, remoteBackend1), (remoteDomain2, remoteBackend2)] + mkUserIds domain = map (flip Qualified domain . (.id)) . S.toList + localTargets = mkUserIds localDomain localTargetUsers + target1 = mkUserIds remoteDomain1 targetUsers1 + target2 = mkUserIds remoteDomain2 targetUsers2 + retrievedProfiles = + runFederationStack ([viewer] <> S.toList localTargetUsers) federation Nothing (UserSubsystemConfig visibility miniLocale) $ + getUserProfiles + (toLocalUnsafe localDomain viewer.id) + (localTargets <> target1 <> target2) + mkExpectedProfiles domain users = + [ mkUserProfileWithEmail + Nothing + (mkUserFromStored domain miniLocale targetUser) + defUserLegalHoldStatus + | targetUser <- S.toList users + ] + expectedLocalProfiles = mkExpectedProfiles localDomain localTargetUsers + expectedProfiles1 = mkExpectedProfiles remoteDomain1 targetUsers1 + expectedProfiles2 = mkExpectedProfiles remoteDomain2 targetUsers2 + expectedProfiles = expectedLocalProfiles <> expectedProfiles1 <> expectedProfiles2 + + sortOn (.profileQualifiedId) retrievedProfiles + === sortOn (.profileQualifiedId) expectedProfiles + + prop "fails when a backend is offline or returns an error" $ + \viewer onlineTargetUsers (offlineTargetUsers :: Set StoredUser) visibility localDomain onlineDomain (offlineDomain :: Domain) -> do + let onlineRemoteBackend = def {users = onlineTargetUsers} + online = [(onlineDomain, onlineRemoteBackend)] + mkUserIds domain users = map (flip Qualified domain . (.id)) (S.toList users) + onlineUsers = mkUserIds onlineDomain onlineTargetUsers + offlineUsers = mkUserIds offlineDomain offlineTargetUsers + config = UserSubsystemConfig visibility miniLocale + + result = + runFederationStackEither [viewer] online Nothing config $ + getUserProfiles + (toLocalUnsafe localDomain viewer.id) + (onlineUsers <> offlineUsers) + localDomain /= offlineDomain && offlineTargetUsers /= [] ==> + -- The FederationError doesn't have an instance + -- for Eq because of dependency on HTTP2Error + first (displayException) result + === Left (displayException (FederationUnexpectedError "RunFederatedEither")) + + describe "[without federation]" do + prop "returns nothing when none of the users exist" $ + \viewer targetUserIds visibility domain locale -> + let config = UserSubsystemConfig visibility locale + retrievedProfiles = + runNoFederationStack [] Nothing config $ + getUserProfiles (toLocalUnsafe domain viewer) (map (`Qualified` domain) targetUserIds) + in retrievedProfiles === [] + + prop "gets a local user profile when the user exists and both user and viewer have accepted their invitations" $ + \(NotPendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) visibility domain locale sameTeam -> + let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus + targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam + config = UserSubsystemConfig visibility locale + retrievedProfiles = + runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] + in retrievedProfiles + === [ mkUserProfile + (fmap (const $ (,) <$> viewer.teamId <*> Just teamMember) visibility) + (mkUserFromStored domain locale targetUser) + defUserLegalHoldStatus + ] + + prop "gets a local user profile when the target user exists and has accepted their invitation but the viewer has not accepted their invitation" $ + \(PendingStoredUser viewer) (NotPendingStoredUser targetUserNoTeam) visibility domain locale sameTeam -> + let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus + targetUser = if sameTeam then targetUserNoTeam {teamId = viewer.teamId} else targetUserNoTeam + config = UserSubsystemConfig visibility locale + retrievedProfile = + runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + getUserProfiles (toLocalUnsafe domain viewer.id) [Qualified targetUser.id domain] + in retrievedProfile + === [ mkUserProfile + (fmap (const Nothing) visibility) + (mkUserFromStored domain locale targetUser) + defUserLegalHoldStatus + ] + + prop "returns Nothing if the target user has not accepted their invitation yet" $ + \viewer (PendingStoredUser targetUser) visibility domain locale -> + let teamMember = mkTeamMember viewer.id fullPermissions Nothing defUserLegalHoldStatus + config = UserSubsystemConfig visibility locale + retrievedProfile = + runNoFederationStack [targetUser, viewer] (Just teamMember) config $ + getLocalUserProfiles (toLocalUnsafe domain [targetUser.id]) + in retrievedProfile === [] + + describe "getUserProfilesWithErrors" $ do + prop "If no errors, same behavior as getUserProfiles" $ + \viewer targetUsers visibility domain remoteDomain -> do + let remoteBackend = def {users = targetUsers} + federation = [(remoteDomain, remoteBackend)] + config = UserSubsystemConfig visibility miniLocale + retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = + runFederationStack [viewer] federation Nothing config $ + getUserProfilesWithErrors + (toLocalUnsafe domain viewer.id) + ( map (flip Qualified remoteDomain . (.id)) $ + S.toList targetUsers + ) + retrievedProfiles :: [UserProfile] = + runFederationStack [viewer] federation Nothing config $ + getUserProfiles + (toLocalUnsafe domain viewer.id) + ( map (flip Qualified remoteDomain . (.id)) $ + S.toList targetUsers + ) + remoteDomain /= domain ==> + counterexample ("Retrieved profiles with errors: " <> show retrievedProfilesWithErrors) do + length (fst retrievedProfilesWithErrors) === 0 + .&&. snd retrievedProfilesWithErrors === retrievedProfiles + .&&. length (snd retrievedProfilesWithErrors) === length targetUsers + + prop "Remote users on offline backend always fail to return" $ + \viewer (targetUsers :: Set StoredUser) visibility domain remoteDomain -> do + let online = mempty + config = UserSubsystemConfig visibility miniLocale + retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = + runFederationStack [viewer] online Nothing config $ + getUserProfilesWithErrors + (toLocalUnsafe domain viewer.id) + ( map (flip Qualified remoteDomain . (.id)) $ + S.toList targetUsers + ) + remoteDomain /= domain ==> + length (fst retrievedProfilesWithErrors) === length targetUsers + .&&. length (snd retrievedProfilesWithErrors) === 0 + + prop "Remote users with one offline and one online backend return errors for offline backend but successed with online backend" $ + \viewer targetUsers visibility domain remoteDomainA remoteDomainB -> do + let remoteBackendA = def {users = targetUsers} + online = [(remoteDomainA, remoteBackendA)] + allDomains = [domain, remoteDomainA, remoteDomainB] + remoteAUsers = map (flip Qualified remoteDomainA . (.id)) (S.toList targetUsers) + remoteBUsers = map (flip Qualified remoteDomainB . (.id)) (S.toList targetUsers) + config = UserSubsystemConfig visibility miniLocale + retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = + runFederationStack [viewer] online Nothing config $ + getUserProfilesWithErrors + (toLocalUnsafe domain viewer.id) + (remoteAUsers <> remoteBUsers) + nub allDomains == allDomains ==> + length (fst retrievedProfilesWithErrors) === length remoteBUsers + .&&. length (snd retrievedProfilesWithErrors) === length remoteAUsers diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 1c7676e7140..c959beac511 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -65,37 +65,83 @@ common common-all library import: common-all + ghc-options: -fplugin=Polysemy.Plugin -fplugin=TransitiveAnns.Plugin -- cabal-fmt: expand src exposed-modules: + Wire.DeleteQueue + Wire.DeleteQueue.InMemory + Wire.FederationAPIAccess + Wire.FederationAPIAccess.Interpreter + Wire.GalleyAPIAccess + Wire.GalleyAPIAccess.Rpc Wire.GundeckAPIAccess + Wire.InternalEvent + Wire.MiniBackend Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter + Wire.ParseException Wire.Rpc + Wire.StoredUser + Wire.UserStore + Wire.UserStore.Cassandra + Wire.UserSubsystem + Wire.UserSubsystem.Interpreter hs-source-dirs: src build-depends: , aeson + , amazonka + , amazonka-core + , amazonka-sqs , async , base + , base16-bytestring , bilge + , bytestring , bytestring-conversion + , cassandra-util , containers + , cql + , currency-codes + , data-default + , errors , exceptions , extended + , extra , gundeck-types + , HsOpenSSL + , hspec , http-client , http-types + , http2-manager , imports + , iso639 , lens + , mime + , mime-mail + , network-conduit-tls , polysemy + , polysemy-plugin + , polysemy-time , polysemy-wire-zoo , QuickCheck + , resourcet , retry + , servant + , servant-client-core + , stomp-queue , text + , time , tinylog + , transformers + , transitive-anns , types-common + , unliftio + , uuid + , wai-utilities , wire-api + , wire-api-federation default-language: GHC2021 @@ -105,11 +151,14 @@ test-suite wire-subsystems-tests default-language: GHC2021 hs-source-dirs: test/unit main-is: ../Main.hs + ghc-options: -fplugin=Polysemy.Plugin -- cabal-fmt: expand test/unit other-modules: Spec Wire.NotificationSubsystem.InterpreterSpec + Wire.UserStoreSpec + Wire.UserSubsystem.InterpreterSpec build-tool-depends: hspec-discover:hspec-discover build-depends: @@ -119,15 +168,23 @@ test-suite wire-subsystems-tests , bilge , bytestring , containers + , data-default , extended , gundeck-types , hspec , imports + , iso639 , polysemy + , polysemy-plugin + , polysemy-time , polysemy-wire-zoo , QuickCheck , quickcheck-instances + , servant-client-core , string-conversions + , time + , transformers , types-common , wire-api + , wire-api-federation , wire-subsystems diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 9ad17d98040..29d5d17791a 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -117,6 +117,7 @@ library Brig.Data.Types Brig.Data.User Brig.Data.UserKey + Brig.DeleteQueue.Interpreter Brig.Effects.BlacklistPhonePrefixStore Brig.Effects.BlacklistPhonePrefixStore.Cassandra Brig.Effects.BlacklistStore @@ -127,8 +128,6 @@ library Brig.Effects.ConnectionStore.Cassandra Brig.Effects.FederationConfigStore Brig.Effects.FederationConfigStore.Cassandra - Brig.Effects.GalleyProvider - Brig.Effects.GalleyProvider.RPC Brig.Effects.JwtTools Brig.Effects.PasswordResetStore Brig.Effects.PasswordResetStore.CodeStore @@ -207,7 +206,6 @@ library Brig.Team.DB Brig.Team.Email Brig.Team.Template - Brig.Team.Types Brig.Team.Util Brig.Template Brig.Unique @@ -585,3 +583,4 @@ test-suite brig-tests , uri-bytestring , uuid , wire-api + , wire-subsystems diff --git a/services/brig/default.nix b/services/brig/default.nix index fc3eff7812f..a7c6a8cfdb9 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -411,6 +411,7 @@ mkDerivation { uri-bytestring uuid wire-api + wire-subsystems ]; description = "User Service"; license = lib.licenses.agpl3Only; diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index 889a12d9b40..bc88f31413b 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -25,7 +25,6 @@ import Brig.App import Brig.Data.User qualified as User import Brig.Effects.BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.GalleyProvider import Brig.Options import Brig.User.Auth qualified as Auth import Brig.ZAuth hiding (Env, settings) @@ -52,6 +51,7 @@ import Wire.API.User.Auth hiding (access) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso +import Wire.GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (InternalPaging) @@ -97,7 +97,7 @@ sendLoginCode (SendLoginCode phone call force) = do pure $ LoginCodeTimeout (pendingLoginTimeout c) login :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -160,7 +160,7 @@ removeCookies lusr (RemoveCookies pw lls ids) = Auth.revokeAccess (tUnqualified lusr) pw ids lls !>> authError legalHoldLogin :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, @@ -196,7 +196,7 @@ getLoginCode phone = do code <- lift $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) pure code -reauthenticate :: Member GalleyProvider r => UserId -> ReAuthUser -> Handler r () +reauthenticate :: Member GalleyAPIAccess r => UserId -> ReAuthUser -> Handler r () reauthenticate uid body = do wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError case reAuthCodeAction body of diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 2fbd3390af5..3176421f984 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -54,8 +54,6 @@ import Brig.Data.Client qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.JwtTools qualified as JwtTools import Brig.Effects.PublicKeyBundle (PublicKeyBundle) @@ -64,9 +62,7 @@ import Brig.Federation.Client (getUserClients) import Brig.Federation.Client qualified as Federation import Brig.IO.Intra (guardLegalhold) import Brig.IO.Intra qualified as Intra -import Brig.InternalEvent.Types qualified as Internal import Brig.Options qualified as Opt -import Brig.Queue qualified as Queue import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.User.Auth qualified as UserAuth @@ -112,6 +108,9 @@ import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey import Wire.API.UserEvent import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) +import Wire.DeleteQueue +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) @@ -162,10 +161,11 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap ( lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk addClient :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, + Member DeleteQueue r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -180,12 +180,13 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients -- a superset of the clients known to galley. addClientWithReAuthPolicy :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member DeleteQueue r, Member (ConnectionStore InternalPaging) r ) => Data.ReAuthPolicy -> @@ -213,7 +214,7 @@ addClientWithReAuthPolicy policy u con new = do let usr = accountUser acc lift $ do for_ old $ execDelete u con - liftSem $ GalleyProvider.newClient u (clientId clt) + liftSem $ GalleyAPIAccess.newClient u (clientId clt) liftSem $ Intra.onClientEvent u con (ClientAdded clt) when (clientType clt == LegalHoldClientType) $ liftSem $ Intra.onUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ @@ -251,7 +252,13 @@ updateClient u c r = do -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword6 -> ExceptT ClientError (AppT r) () +rmClient :: + Member DeleteQueue r => + UserId -> + ConnId -> + ClientId -> + Maybe PlainTextPassword6 -> + ExceptT ClientError (AppT r) () rmClient u con clt pw = maybe (throwE ClientNotFound) fn =<< lift (wrapClient $ Data.lookupClient u clt) where @@ -266,6 +273,7 @@ rmClient u con clt pw = lift $ execDelete u (Just con) client claimPrekey :: + Member DeleteQueue r => LegalholdProtectee -> UserId -> Domain -> @@ -278,6 +286,7 @@ claimPrekey protectee u d c = do else wrapClientE $ claimRemotePrekey (Qualified u d) c claimLocalPrekey :: + Member DeleteQueue r => LegalholdProtectee -> UserId -> ClientId -> @@ -317,7 +326,9 @@ claimRemotePrekeyBundle quser = do Federation.claimPrekeyBundle quser !>> ClientFederationError claimMultiPrekeyBundlesInternal :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => LegalholdProtectee -> QualifiedUserClients -> ExceptT @@ -337,7 +348,9 @@ claimMultiPrekeyBundlesInternal protectee quc = do pure (localPrekeys, remotes) where claimLocal :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => Local UserClients -> ExceptT ClientError (AppT r) (Qualified UserClientPrekeyMap) claimLocal luc = @@ -345,7 +358,9 @@ claimMultiPrekeyBundlesInternal protectee quc = do <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) claimMultiPrekeyBundlesV3 :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMap @@ -378,7 +393,9 @@ claimMultiPrekeyBundlesV3 protectee quc = do -- to fail, allowing partial results to be returned. claimMultiPrekeyBundles :: forall r. - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMapV4 @@ -405,7 +422,9 @@ claimMultiPrekeyBundles protectee quc = do claimLocalMultiPrekeyBundles :: forall r. - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => LegalholdProtectee -> UserClients -> ExceptT ClientError (AppT r) UserClientPrekeyMap @@ -447,11 +466,15 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- Utilities -- | Enqueue an orderly deletion of an existing client. -execDelete :: UserId -> Maybe ConnId -> Client -> (AppT r) () +execDelete :: + Member DeleteQueue r => + UserId -> + Maybe ConnId -> + Client -> + AppT r () execDelete u con c = do for_ (clientCookie c) $ \l -> wrapClient $ Auth.revokeCookies u [] [l] - queue <- view internalEvents - Queue.enqueue queue (Internal.DeleteClient (clientId c) u con) + liftSem $ enqueueClientDeletion c.clientId u con wrapClient $ Data.rmClient u (clientId c) -- | Defensive measure when no prekey is found for a @@ -460,6 +483,7 @@ execDelete u con c = do -- thus repairing any inconsistencies related to distributed -- (and possibly duplicated) client data. noPrekeys :: + Member DeleteQueue r => UserId -> ClientId -> (AppT r) () @@ -511,6 +535,7 @@ removeLegalHoldClient :: Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, + Member DeleteQueue r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r ) => diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index c5b8de1c4c2..cc499656310 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -42,8 +42,6 @@ import Brig.Data.Connection qualified as Data import Brig.Data.Types (resultHasMore, resultList) import Brig.Data.User qualified as Data import Brig.Effects.FederationConfigStore -import Brig.Effects.GalleyProvider -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.IO.Intra qualified as Intra import Brig.IO.Logging import Brig.Options @@ -70,18 +68,20 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem -ensureNotSameTeam :: Member GalleyProvider r => Local UserId -> Local UserId -> (ConnectionM r) () +ensureNotSameTeam :: Member GalleyAPIAccess r => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do - selfTeam <- lift $ liftSem $ GalleyProvider.getTeamId (tUnqualified self) - targetTeam <- lift $ liftSem $ GalleyProvider.getTeamId (tUnqualified target) + selfTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified self) + targetTeam <- lift $ liftSem $ GalleyAPIAccess.getTeamId (tUnqualified target) when (isJust selfTeam && selfTeam == targetTeam) $ throwE ConnectSameBindingTeamUsers createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -100,7 +100,7 @@ createConnection self con target = do createConnectionToLocalUser :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -191,7 +191,7 @@ createConnectionToLocalUser self conn target = do -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. checkLegalholdPolicyConflict :: - Member GalleyProvider r => + Member GalleyAPIAccess r => UserId -> UserId -> ExceptT ConnectionError (AppT r) () @@ -221,7 +221,7 @@ updateConnection :: Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => Local UserId -> Qualified UserId -> @@ -244,7 +244,7 @@ updateConnection self other newStatus conn = updateConnectionToLocalUser :: forall r. ( Member (Embed HttpClientIO) r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r ) => @@ -417,7 +417,7 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index c96ecd24a5b..d9de83ccef5 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -29,7 +29,6 @@ import Brig.App import Brig.Data.Connection qualified as Data import Brig.Data.User qualified as Data import Brig.Effects.FederationConfigStore -import Brig.Effects.GalleyProvider import Brig.Federation.Client as Federation import Brig.IO.Intra qualified as Intra import Brig.Options @@ -52,6 +51,7 @@ import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User import Wire.API.UserEvent +import Wire.GalleyAPIAccess import Wire.NotificationSubsystem data LocalConnectionAction @@ -152,7 +152,7 @@ desiredMembership a r = -- -- Returns the connection, and whether it was updated or not. transitionTo :: - (Member GalleyProvider r, Member NotificationSubsystem r) => + (Member GalleyAPIAccess r, Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -224,7 +224,7 @@ pushEvent self mzcon connection = do liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: - (Member GalleyProvider r, Member NotificationSubsystem r) => + (Member GalleyAPIAccess r, Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -280,7 +280,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: - (Member GalleyProvider r, Member NotificationSubsystem r) => + (Member GalleyAPIAccess r, Member NotificationSubsystem r) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -298,7 +298,7 @@ performRemoteAction self other mconnection action = do reaction _ = Nothing createConnectionToRemoteUser :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member FederationConfigStore r, Member NotificationSubsystem r ) => @@ -313,7 +313,7 @@ createConnectionToRemoteUser self zcon other = do fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member FederationConfigStore r ) => diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 9a6559663c6..b48dd6e10fd 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -33,7 +33,6 @@ import Brig.Data.Connection qualified as Data import Brig.Data.User qualified as Data import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.FederationConfigStore qualified as E -import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.IO.Intra (notify) import Brig.Options import Brig.User.API.Handle @@ -70,16 +69,21 @@ import Wire.API.User.Client.Prekey import Wire.API.User.Search hiding (searchPolicy) import Wire.API.UserEvent import Wire.API.UserMap (UserMap) +import Wire.DeleteQueue +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.NotificationSubsystem import Wire.Sem.Concurrency +import Wire.UserSubsystem type FederationAPI = "federation" :> BrigApi federationSitemap :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Concurrency 'Unsafe) r, Member FederationConfigStore r, - Member NotificationSubsystem r + Member NotificationSubsystem r, + Member UserSubsystem r, + Member DeleteQueue r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -111,7 +115,7 @@ getFederationStatus _ request = do sendConnectionAction :: ( Member FederationConfigStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member NotificationSubsystem r ) => Domain -> @@ -134,8 +138,8 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do else pure NewConnectionResponseNotFederating getUserByHandle :: - ( Member GalleyProvider r, - Member FederationConfigStore r + ( Member FederationConfigStore r, + Member UserSubsystem r ) => Domain -> Handle -> @@ -155,18 +159,20 @@ getUserByHandle domain handle = do case maybeOwnerId of Nothing -> pure Nothing - Just ownerId -> - listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] + Just ownerId -> do + localOwnerId <- qualifyLocal ownerId + liftSem $ getLocalUserProfile localOwnerId getUsersByIds :: - Member GalleyProvider r => + (Member UserSubsystem r) => Domain -> [UserId] -> ExceptT Error (AppT r) [UserProfile] -getUsersByIds _ uids = - lift (API.lookupLocalProfiles Nothing uids) +getUsersByIds _ uids = do + luids <- qualifyLocal uids + lift $ liftSem $ getLocalUserProfiles luids -claimPrekey :: Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) +claimPrekey :: (Member DeleteQueue r) => Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) claimPrekey _ (user, client) = do API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client !>> clientError @@ -175,7 +181,7 @@ claimPrekeyBundle _ user = API.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user !>> clientError claimMultiPrekeyBundle :: - Member (Concurrency 'Unsafe) r => + (Member (Concurrency 'Unsafe) r, Member DeleteQueue r) => Domain -> UserClients -> Handler r UserClientPrekeyMap @@ -195,8 +201,8 @@ fedClaimKeyPackages domain ckpr = -- | Searching for federated users on a remote backend searchUsers :: forall r. - ( Member GalleyProvider r, - Member FederationConfigStore r + ( Member FederationConfigStore r, + Member UserSubsystem r ) => Domain -> SearchRequest -> @@ -237,8 +243,9 @@ searchUsers domain (SearchRequest searchTerm mTeam mOnlyInTeams) = do Nothing -> pure [] Just foundUser -> do mFoundUserTeamId <- lift $ wrapClient $ Data.lookupUserTeam foundUser + localFoundUser <- qualifyLocal foundUser if isTeamAllowed mOnlyInTeams mFoundUserTeamId - then lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] + then lift $ liftSem $ (fmap contactFromProfile . maybeToList) <$> getLocalUserProfile localFoundUser else pure [] | otherwise = pure [] diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 12e529d9886..0cbe0829f48 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -43,7 +43,6 @@ import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.FederationConfigStore (AddFederationRemoteResult (..), AddFederationRemoteTeamResult (..), FederationConfigStore, UpdateFederationResult (..)) import Brig.Effects.FederationConfigStore qualified as E -import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.IO.Intra qualified as Intra @@ -51,7 +50,6 @@ import Brig.Options hiding (internalEvents, sesQueue) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team import Brig.Team.DB (lookupInvitationByEmail) -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -98,6 +96,8 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent +import Wire.DeleteQueue +import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Concurrency @@ -107,12 +107,13 @@ servantSitemap :: forall r p. ( Member BlacklistPhonePrefixStore r, Member BlacklistStore r, + Member DeleteQueue r, Member CodeStore r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member FederationConfigStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member NotificationSubsystem r, @@ -141,7 +142,7 @@ istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r) istatusAPI = Named @"get-status" (pure NoContent) ejpdAPI :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member Rpc r ) => @@ -157,7 +158,8 @@ accountAPI :: Member CodeStore r, Member BlacklistPhonePrefixStore r, Member PasswordResetStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, + Member DeleteQueue r, Member (UserPendingActivationStore p) r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -207,7 +209,7 @@ accountAPI = :<|> Named @"iLegalholdDeleteClient" removeLegalHoldClientH teamsAPI :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member BlacklistStore r, Member (Embed HttpClientIO) r, @@ -238,7 +240,7 @@ clientAPI :: ServerT BrigIRoutes.ClientAPI (Handler r) clientAPI = Named @"update-client-last-active" updateClientLastActive authAPI :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -375,9 +377,10 @@ internalSearchIndexAPI = -- | Add a client without authentication checks addClientInternalH :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member DeleteQueue r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -411,6 +414,7 @@ legalHoldClientRequestedH targetUser clientRequest = do removeLegalHoldClientH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member DeleteQueue r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -432,7 +436,7 @@ internalListFullClientsH (UserSet usrs) = lift $ do createUserNoVerify :: ( Member BlacklistStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, @@ -457,7 +461,7 @@ createUserNoVerify uData = lift . runExceptT $ do pure . SelfProfile $ usr createUserNoVerifySpar :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, @@ -518,6 +522,7 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do -- handler allows up to 4 lists of various user keys, and returns the union of the lookups. -- Empty list is forbidden for backwards compatibility. listActivatedAccountsH :: + Member DeleteQueue r => Maybe (CommaSeparatedList UserId) -> Maybe (CommaSeparatedList Handle) -> Maybe (CommaSeparatedList Email) -> @@ -539,7 +544,11 @@ listActivatedAccountsH u4 <- (\phone -> API.lookupAccountsByIdentity (Right phone) includePendingInvitations) `mapM` phones pure $ u1 <> u2 <> join u3 <> join u4 -listActivatedAccounts :: Either [UserId] [Handle] -> Bool -> (AppT r) [UserAccount] +listActivatedAccounts :: + Member DeleteQueue r => + Either [UserId] [Handle] -> + Bool -> + (AppT r) [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of @@ -548,10 +557,10 @@ listActivatedAccounts elh includePendingInvitations = do us <- mapM (wrapClient . API.lookupHandle) hs byIds (catMaybes us) where - byIds :: [UserId] -> (AppT r) [UserAccount] + byIds :: Member DeleteQueue r => [UserId] -> (AppT r) [UserAccount] byIds uids = wrapClient (API.lookupAccounts uids) >>= filterM accountValid - accountValid :: UserAccount -> (AppT r) Bool + accountValid :: Member DeleteQueue r => UserAccount -> (AppT r) Bool accountValid account = case userIdentity . accountUser $ account of Nothing -> pure False Just ident -> @@ -561,7 +570,7 @@ listActivatedAccounts elh includePendingInvitations = do hasInvitation <- isJust <$> wrapClient (lookupInvitationByEmail HideInvitationUrl email) unless hasInvitation $ do -- user invited via scim should expire together with its invitation - API.deleteUserNoVerify (userId . accountUser $ account) + liftSem $ API.deleteUserNoVerify (userId . accountUser $ account) pure hasInvitation (PendingInvitation, True, Nothing) -> pure True -- cannot happen, user invited via scim always has an email @@ -678,7 +687,7 @@ revokeIdentityH bade badp = ) updateConnectionInternalH :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -830,7 +839,7 @@ getRichInfoMultiH (maybe [] fromCommaSeparatedList -> uids) = updateHandleH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -847,7 +856,7 @@ updateHandleH uid (HandleUpdate handleUpd) = updateUserNameH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index f4d77b27a52..ec797bf83fa 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -50,8 +50,6 @@ import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.FederationConfigStore (FederationConfigStore) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) @@ -158,11 +156,15 @@ import Wire.API.User.Password qualified as Public import Wire.API.User.RichInfo qualified as Public import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public +import Wire.DeleteQueue +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSubsystem -- User API ----------------------------------------------------------- @@ -277,17 +279,19 @@ servantSitemap :: ( Member BlacklistPhonePrefixStore r, Member BlacklistStore r, Member CodeStore r, + Member DeleteQueue r, Member (Concurrency 'Unsafe) r, Member (ConnectionStore InternalPaging) r, Member (Embed HttpClientIO) r, Member (Embed IO) r, Member FederationConfigStore r, - Member GalleyProvider r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member Jwk r, + Member GalleyAPIAccess r, Member JwtTools r, Member NotificationSubsystem r, + Member UserSubsystem r, Member Now r, Member PasswordResetStore r, Member PublicKeyBundle r, @@ -320,7 +324,7 @@ servantSitemap = userAPI :: ServerT UserAPI (Handler r) userAPI = Named @"get-user-unqualified" (callsFed (exposeAnnotations getUserUnqualifiedH)) - :<|> Named @"get-user-qualified" (callsFed (exposeAnnotations getUser)) + :<|> Named @"get-user-qualified" (callsFed (exposeAnnotations getUserProfileH)) :<|> Named @"update-user-email" updateUserEmail :<|> Named @"get-handle-info-unqualified" (callsFed (exposeAnnotations getHandleInfoUnqualifiedH)) :<|> Named @"get-user-by-handle-qualified" (callsFed (exposeAnnotations Handle.getHandleInfo)) @@ -518,12 +522,22 @@ listPropertyKeysAndValues u = do keysAndVals <- fmap Map.fromList . lift $ wrapClient (API.lookupPropertyKeysAndValues u) Public.PropertyKeysAndValues <$> traverse parseStoredPropertyValue keysAndVals -getPrekeyUnqualifiedH :: UserId -> UserId -> ClientId -> (Handler r) Public.ClientPrekey +getPrekeyUnqualifiedH :: + Member DeleteQueue r => + UserId -> + UserId -> + ClientId -> + (Handler r) Public.ClientPrekey getPrekeyUnqualifiedH zusr user client = do domain <- viewFederationDomain getPrekeyH zusr (Qualified user domain) client -getPrekeyH :: UserId -> Qualified UserId -> ClientId -> (Handler r) Public.ClientPrekey +getPrekeyH :: + Member DeleteQueue r => + UserId -> + Qualified UserId -> + ClientId -> + (Handler r) Public.ClientPrekey getPrekeyH zusr (Qualified user domain) client = do mPrekey <- API.claimPrekey (ProtectedUser zusr) user domain client !>> clientError ifNothing (notFound "prekey not found") mPrekey @@ -538,7 +552,9 @@ getPrekeyBundleH zusr (Qualified uid domain) = API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError getMultiUserPrekeyBundleUnqualifiedH :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => UserId -> Public.UserClients -> Handler r Public.UserClientPrekeyMap @@ -562,7 +578,9 @@ getMultiUserPrekeyBundleHInternal qualUserClients = do throwStd (errorToWai @'E.TooManyClients) getMultiUserPrekeyBundleHV3 :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMap @@ -571,7 +589,9 @@ getMultiUserPrekeyBundleHV3 zusr qualUserClients = do API.claimMultiPrekeyBundlesV3 (ProtectedUser zusr) qualUserClients !>> clientError getMultiUserPrekeyBundleH :: - Member (Concurrency 'Unsafe) r => + ( Member (Concurrency 'Unsafe) r, + Member DeleteQueue r + ) => UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMapV4 @@ -580,8 +600,9 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError addClient :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, + Member DeleteQueue r, Member NotificationSubsystem r, Member TinyLog r, Member (Input (Local ())) r, @@ -599,7 +620,13 @@ addClient usr con new = do API.addClient usr (Just con) new !>> clientError -deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> (Handler r) () +deleteClient :: + Member DeleteQueue r => + UserId -> + ConnId -> + ClientId -> + Public.RmClient -> + (Handler r) () deleteClient usr con clt body = API.rmClient usr con clt (Public.rmPassword body) !>> clientError @@ -661,12 +688,12 @@ getRichInfo self user = do wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo user getSupportedProtocols :: - Member GalleyProvider r => + (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Handler r (Set Public.BaseProtocolTag) getSupportedProtocols lself quid = do - muser <- API.lookupProfile lself quid !>> fedError + muser <- (lift . liftSem $ getUserProfile lself quid) !>> fedError user <- maybe (throwStd (errorToWai @'E.UserNotFound)) pure muser pure (Public.profileSupportedProtocols user) @@ -701,7 +728,7 @@ createAccessToken method luid cid proof = do -- | docs/reference/user/registration.md {#RefRegistration} createUser :: ( Member BlacklistStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, @@ -781,35 +808,31 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do Public.NewTeamMemberSSO _ -> Team.sendMemberWelcomeMail e t n l -getSelf :: Member GalleyProvider r => UserId -> (Handler r) Public.SelfProfile +getSelf :: Member GalleyAPIAccess r => UserId -> (Handler r) Public.SelfProfile getSelf self = lift (API.lookupSelfProfile self) >>= ifNothing (errorToWai @'E.UserNotFound) >>= lift . liftSem . API.hackForBlockingHandleChangeForE2EIdTeams -getUserUnqualifiedH :: - (Member GalleyProvider r) => - UserId -> - UserId -> +getUserProfileH :: + (Member UserSubsystem r) => + Local UserId -> + Qualified UserId -> (Handler r) (Maybe Public.UserProfile) -getUserUnqualifiedH self uid = do - domain <- viewFederationDomain - getUser self (Qualified uid domain) +getUserProfileH u us = (lift . liftSem) $ getUserProfile u us -getUser :: - (Member GalleyProvider r) => +getUserUnqualifiedH :: + (Member UserSubsystem r) => + Local UserId -> UserId -> - Qualified UserId -> (Handler r) (Maybe Public.UserProfile) -getUser self qualifiedUserId = do - lself <- qualifyLocal self - API.lookupProfile lself qualifiedUserId !>> fedError +getUserUnqualifiedH self uid = do + let domain = tDomain self + lift . liftSem $ getUserProfile self (Qualified uid domain) -- FUTUREWORK: Make servant understand that at least one of these is required listUsersByUnqualifiedIdsOrHandles :: - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r - ) => + (Member UserSubsystem r) => UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> @@ -842,9 +865,7 @@ listUsersByIdsOrHandlesGetUsers lself hs = do listUsersByIdsOrHandlesV3 :: forall r. - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r - ) => + (Member UserSubsystem r) => UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] @@ -861,15 +882,13 @@ listUsersByIdsOrHandlesV3 self q = do _ -> pure foundUsers where byIds :: Local UserId -> [Qualified UserId] -> (Handler r) [Public.UserProfile] - byIds lself uids = API.lookupProfiles lself uids !>> fedError + byIds lself uids = (lift . liftSem $ getUserProfiles lself uids) !>> fedError -- Similar to listUsersByIdsOrHandlesV3, except that it allows partial successes -- using a new return type listUsersByIdsOrHandles :: forall r. - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r - ) => + (Member UserSubsystem r) => UserId -> Public.ListUsersQuery -> Handler r ListUsersById @@ -889,7 +908,7 @@ listUsersByIdsOrHandles self q = do Local UserId -> [Qualified UserId] -> Handler r ([(Qualified UserId, FederationError)], [Public.UserProfile]) - byIds lself uids = lift (API.lookupProfilesV3 lself uids) !>> fedError + byIds lself uids = lift (liftSem (getUserProfilesWithErrors lself uids)) newtype GetActivationCodeResp = GetActivationCodeResp (Public.ActivationKey, Public.ActivationCode) @@ -900,7 +919,7 @@ instance ToJSON GetActivationCodeResp where updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -1012,7 +1031,7 @@ checkHandles _ (Public.CheckHandles hs num) = do -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. getHandleInfoUnqualifiedH :: - ( Member GalleyProvider r + ( Member UserSubsystem r ) => UserId -> Handle -> @@ -1025,7 +1044,7 @@ getHandleInfoUnqualifiedH self handle = do changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -1066,7 +1085,7 @@ completePasswordReset req = do sendActivationCode :: ( Member BlacklistStore r, Member BlacklistPhonePrefixStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => Public.SendActivationCode -> (Handler r) () @@ -1092,7 +1111,7 @@ customerExtensionCheckBlockedDomains email = do customerExtensionBlockedDomain domain createConnectionUnqualified :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -1108,7 +1127,7 @@ createConnectionUnqualified self conn cr = do createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -1122,7 +1141,7 @@ createConnection self conn target = do API.createConnection lself conn target !>> connError updateLocalConnection :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r @@ -1143,7 +1162,7 @@ updateConnection :: Member NotificationSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => UserId -> ConnId -> @@ -1214,7 +1233,7 @@ getConnection self other = do lift . wrapClient $ Data.lookupConnection lself other deleteSelfUser :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1243,7 +1262,7 @@ verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError updateUserEmail :: forall r. ( Member BlacklistStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => UserId -> UserId -> @@ -1266,13 +1285,13 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do where check = runMaybeT $ do teamId <- hoistMaybe maybeTeamId - teamMember <- MaybeT $ lift $ liftSem $ GalleyProvider.getTeamMember zuserId teamId + teamMember <- MaybeT $ lift $ liftSem $ GalleyAPIAccess.getTeamMember zuserId teamId pure $ teamMember `hasPermission` ChangeTeamMemberProfiles -- activation activate :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1289,7 +1308,7 @@ activate k c = do -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1314,7 +1333,7 @@ activateKey (Public.Activate tgt code dryrun) sendVerificationCode :: forall r. - Member GalleyProvider r => + Member GalleyAPIAccess r => Public.SendVerificationCode -> (Handler r) () sendVerificationCode req = do @@ -1351,7 +1370,7 @@ sendVerificationCode req = do getFeatureStatus :: Maybe UserAccount -> (Handler r) Bool getFeatureStatus mbAccount = do - mbStatusEnabled <- lift $ liftSem $ GalleyProvider.getVerificationCodeEnabled `traverse` (Public.userTeam <$> accountUser =<< mbAccount) + mbStatusEnabled <- lift $ liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` (Public.userTeam <$> accountUser =<< mbAccount) pure $ fromMaybe False mbStatusEnabled getSystemSettings :: (Handler r) SystemSettingsPublic diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 05e4a2b43aa..c80dd866ff6 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -39,10 +39,7 @@ module Brig.API.User Data.lookupAccount, Data.lookupStatus, lookupAccountsByIdentity, - lookupProfile, - lookupProfiles, lookupProfilesV3, - lookupLocalProfiles, getLegalHoldStatus, Data.lookupName, Data.lookupLocale, @@ -116,19 +113,13 @@ import Brig.Effects.BlacklistStore qualified as BlacklistStore import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.CodeStore qualified as E import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.GalleyProvider -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PasswordResetStore qualified as E import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore -import Brig.Federation.Client qualified as Federation import Brig.IO.Intra qualified as Intra -import Brig.InternalEvent.Types qualified as Internal import Brig.Options hiding (Timeout, internalEvents) -import Brig.Queue qualified as Queue import Brig.Team.DB qualified as Team -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Types.Activation (ActivationPair) import Brig.Types.Connection import Brig.Types.Intra @@ -155,7 +146,8 @@ import Data.List1 as List1 (List1, singleton) import Data.Metrics qualified as Metrics import Data.Misc import Data.Qualified -import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) +import Data.Range +import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) import Imports import Network.Wai.Utilities @@ -163,7 +155,6 @@ import Polysemy import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log -import System.Logger.Class (MonadLogger) import System.Logger.Message import UnliftIO.Async (mapConcurrently_) import Wire.API.Connection @@ -176,7 +167,7 @@ import Wire.API.Team hiding (newTeam) import Wire.API.Team.Feature import Wire.API.Team.Invitation import Wire.API.Team.Invitation qualified as Team -import Wire.API.Team.Member (TeamMember, legalHoldStatus) +import Wire.API.Team.Member (legalHoldStatus) import Wire.API.Team.Role import Wire.API.Team.Size import Wire.API.User @@ -185,9 +176,12 @@ import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo import Wire.API.UserEvent +import Wire.DeleteQueue +import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSubsystem data AllowSCIMUpdates = AllowSCIMUpdates @@ -228,7 +222,7 @@ verifyUniquenessAndCheckBlacklist uk = do createUserSpar :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, @@ -255,7 +249,7 @@ createUserSpar new = do case unRichInfo <$> newUserSparRichInfo new of Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do - liftSem $ GalleyProvider.createSelfConv uid + liftSem $ GalleyAPIAccess.createSelfConv uid liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -282,7 +276,7 @@ createUserSpar new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, role) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, role) unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -293,14 +287,14 @@ createUserSpar new = do field "user" (toByteString uid) . field "team" (toByteString tid) . msg (val "Added via SSO") - Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName tid pure $ CreateUserTeam tid nm -- docs/reference/user/registration.md {#RefRegistration} createUser :: forall r p. ( Member BlacklistStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, @@ -315,7 +309,7 @@ createUser new = do (email, phone) <- validateEmailAndPhone new -- get invitation and existing account - (newTeam, teamInvitation, tid) <- + (mNewTeamUser, teamInvitation, tid) <- case newUserTeam new of Just (NewTeamMember i) -> do mbTeamInv <- findTeamInvitation (userEmailKey <$> email) i @@ -364,7 +358,7 @@ createUser new = do Log.info $ field "user" (toByteString uid) . msg (val "Creating user") wrapClient $ Data.insertAccount account Nothing pw False - liftSem $ GalleyProvider.createSelfConv uid + liftSem $ GalleyAPIAccess.createSelfConv uid liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -373,13 +367,14 @@ createUser new = do createUserTeam <- do activatedTeam <- lift $ do - case (tid, newTeam) of - (Just tid', Just nt) -> do - created <- liftSem $ GalleyProvider.createTeam uid (bnuTeam nt) tid' + case (tid, mNewTeamUser) of + (Just tid', Just newTeamUser) -> do + liftSem $ GalleyAPIAccess.createTeam uid (bnuTeam newTeamUser) tid' let activating = isJust (newUserEmailCode new) + BindingNewTeam newTeam = newTeamUser.bnuTeam pure $ if activating - then Just created + then Just $ CreateUserTeam tid' (fromRange (newTeam ^. newTeamName)) else Nothing _ -> pure Nothing @@ -387,7 +382,7 @@ createUser new = do Just (inv, invInfo) -> do let em = Team.inInviteeEmail inv acceptTeamInvitation account inv invInfo (userEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName (Team.inTeam inv) + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName (Team.inTeam inv) pure (Just $ CreateUserTeam (Team.inTeam inv) nm) Nothing -> pure Nothing @@ -400,7 +395,7 @@ createUser new = do edata <- if isJust teamInvitation then pure Nothing - else handleEmailActivation email uid newTeam + else handleEmailActivation email uid mNewTeamUser pdata <- handlePhoneActivation phone uid @@ -453,7 +448,7 @@ createUser new = do throwE RegisterErrorTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. -- Remove after the next release. - canAdd <- lift $ liftSem $ GalleyProvider.checkUserCanJoinTeam tid + canAdd <- lift $ liftSem $ GalleyAPIAccess.checkUserCanJoinTeam tid case canAdd of Just e -> throwM $ API.UserNotAllowedToJoinTeam e Nothing -> pure () @@ -472,7 +467,7 @@ createUser new = do throwE RegisterErrorUserKeyExists let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) - added <- lift $ liftSem $ GalleyProvider.addTeamMember uid (Team.iiTeam ii) minvmeta + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid (Team.iiTeam ii) minvmeta unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -490,7 +485,7 @@ createUser new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, defaultRole) unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -501,7 +496,7 @@ createUser new = do field "user" (toByteString uid) . field "team" (toByteString tid) . msg (val "Added via SSO") - Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName tid pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) @@ -595,7 +590,7 @@ checkRestrictedUserCreation new = do updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -687,7 +682,7 @@ changeSupportedProtocols uid conn prots = do changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -1011,7 +1006,7 @@ mkUserEvent usrs status = -- Activation activate :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1027,7 +1022,7 @@ activate :: activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1060,8 +1055,8 @@ activateWithCurrency tgt code usr cur = do pure $ ActivationSuccess ident first where activateTeam uid = do - tid <- liftSem $ GalleyProvider.getTeamId uid - for_ tid $ \t -> liftSem $ GalleyProvider.changeTeamStatus t Team.Active cur + tid <- liftSem $ GalleyAPIAccess.getTeamId uid + for_ tid $ \t -> liftSem $ GalleyAPIAccess.changeTeamStatus t Team.Active cur preverify :: ( MonadClient m, @@ -1102,7 +1097,7 @@ onActivated (PhoneActivated uid phone) = do sendActivationCode :: ( Member BlacklistStore r, Member BlacklistPhonePrefixStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => Either Email Phone -> Maybe Locale -> @@ -1177,7 +1172,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of loc' = loc <|> Just (userLocale u) void . forEmailKey ek $ \em -> lift $ do -- Get user's team, if any. - mbTeam <- mapM (fmap Team.tdTeam . liftSem . GalleyProvider.getTeam) (userTeam u) + mbTeam <- mapM (fmap Team.tdTeam . liftSem . GalleyAPIAccess.getTeam) (userTeam u) -- Depending on whether the user is a team creator, send either -- a team activation email or a regular email. Note that we -- don't have to check if the team is binding because if the @@ -1305,7 +1300,7 @@ mkPasswordResetKey ident = case ident of -- TODO: communicate deletions of SSO users to SSO service. deleteSelfUser :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -1332,7 +1327,7 @@ deleteSelfUser uid pwd = do case userTeam $ accountUser acc of Nothing -> pure () Just tid -> do - isOwner <- lift $ liftSem $ GalleyProvider.memberIsTeamOwner tid uid + isOwner <- lift $ liftSem $ GalleyAPIAccess.memberIsTeamOwner tid uid when isOwner $ throwE DeleteUserOwnerDeletingSelf go a = maybe (byIdentity a) (byPassword a) pwd getEmailOrPhone :: UserIdentity -> Maybe (Either Email Phone) @@ -1532,166 +1527,47 @@ lookupPasswordResetCode emailOrPhone = do pure $ (k,) <$> c deleteUserNoVerify :: - ( MonadReader Env m, - MonadIO m, - MonadLogger m, - MonadThrow m - ) => + Member DeleteQueue r => UserId -> - m () + Sem r () deleteUserNoVerify uid = do - queue <- view internalEvents - Queue.enqueue queue (Internal.DeleteUser uid) + enqueueUserDeletion uid -deleteUsersNoVerify :: [UserId] -> (AppT r) () +deleteUsersNoVerify :: + (Member DeleteQueue r) => + [UserId] -> + AppT r () deleteUsersNoVerify uids = do - for_ uids deleteUserNoVerify + liftSem $ for_ uids deleteUserNoVerify m <- view metrics Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.enqueue_multi_delete_total") m Metrics.counterIncr (Metrics.path "user.enqueue_multi_delete_calls_total") m --- | Garbage collect users if they're ephemeral and they have expired. --- Always returns the user (deletion itself is delayed) -userGC :: - ( MonadIO m, - MonadReader Env m, - MonadLogger m, - MonadThrow m - ) => - User -> - m User -userGC u = case userExpire u of - Nothing -> pure u - (Just (fromUTCTimeMillis -> e)) -> do - now <- liftIO =<< view currentTime - -- ephemeral users past their expiry date are deleted - when (diffUTCTime e now < 0) $ - deleteUserNoVerify (userId u) - pure u - -lookupProfile :: - (Member GalleyProvider r) => - Local UserId -> - Qualified UserId -> - ExceptT FederationError (AppT r) (Maybe UserProfile) -lookupProfile self other = - listToMaybe - <$> lookupProfilesFromDomain - self - (fmap pure other) - --- | Obtain user profiles for a list of users as they can be seen by --- a given user 'self'. User 'self' can see the 'FullProfile' of any other user 'other', --- if the reverse relation (other -> self) is either 'Accepted' or 'Sent'. --- Otherwise only the 'PublicProfile' is accessible for user 'self'. --- If 'self' is an unknown 'UserId', return '[]'. -lookupProfiles :: - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r - ) => - -- | User 'self' on whose behalf the profiles are requested. - Local UserId -> - -- | The users ('others') for which to obtain the profiles. - [Qualified UserId] -> - ExceptT FederationError (AppT r) [UserProfile] -lookupProfiles self others = - concat - <$> traverseConcurrentlyWithErrorsAppT - (lookupProfilesFromDomain self) - (bucketQualified others) - -- | Similar to lookupProfiles except it returns all results and all errors -- allowing for partial success. lookupProfilesV3 :: - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r - ) => - -- | User 'self' on whose behalf the profiles are requested. + (Member UserSubsystem r) => Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> - AppT r ([(Qualified UserId, FederationError)], [UserProfile]) -lookupProfilesV3 self others = do - t <- - traverseConcurrentlyAppT - (lookupProfilesFromDomain self) - (bucketQualified others) - let (l, r) = partitionEithers t - pure (l >>= flattenUsers, join r) - where - flattenUsers :: (Qualified [UserId], FederationError) -> [(Qualified UserId, FederationError)] - flattenUsers (l, e) = (,e) <$> sequenceA l - -lookupProfilesFromDomain :: - (Member GalleyProvider r) => - Local UserId -> - Qualified [UserId] -> - ExceptT FederationError (AppT r) [UserProfile] -lookupProfilesFromDomain self = - foldQualified - self - (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) - (mapExceptT wrapHttp . lookupRemoteProfiles) - -lookupRemoteProfiles :: - ( MonadIO m, - MonadReader Env m, - MonadLogger m - ) => - Remote [UserId] -> - ExceptT FederationError m [UserProfile] -lookupRemoteProfiles (tUntagged -> Qualified uids domain) = - Federation.getUsersByIds domain uids - --- FUTUREWORK: This function encodes a few business rules about exposing email --- ids, but it is also very complex. Maybe this can be made easy by extracting a --- pure function and writing tests for that. -lookupLocalProfiles :: - forall r. - Member GalleyProvider r => - -- | This is present only when an authenticated user is requesting access. - Maybe UserId -> - -- | The users ('others') for which to obtain the profiles. - [UserId] -> - AppT r [UserProfile] -lookupLocalProfiles requestingUser others = do - users <- wrapHttpClient $ Data.lookupUsers NoPendingInvitations others >>= mapM userGC - emailVisibilityConfig <- view (settings . emailVisibility) - emailVisibilityConfigWithViewer <- - case emailVisibilityConfig of - EmailVisibleIfOnTeam -> pure EmailVisibleIfOnTeam - EmailVisibleToSelf -> pure EmailVisibleToSelf - EmailVisibleIfOnSameTeam () -> - EmailVisibleIfOnSameTeam . join @Maybe - <$> traverse getSelfInfo requestingUser - usersAndStatus <- liftSem $ for users $ \u -> (u,) <$> getLegalHoldStatus' u - pure $ map (uncurry $ mkUserProfile emailVisibilityConfigWithViewer) usersAndStatus - where - getSelfInfo :: UserId -> AppT r (Maybe (TeamId, TeamMember)) - getSelfInfo selfId = do - -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') - -- to return 'Nothing'. we could throw errors here if that happens, rather than just - -- returning an empty profile list from 'lookupProfiles'. - mUser <- wrapHttp $ Data.lookupUser NoPendingInvitations selfId - case userTeam =<< mUser of - Nothing -> pure Nothing - Just tid -> (tid,) <$$> liftSem (GalleyProvider.getTeamMember selfId tid) + Sem r ([(Qualified UserId, FederationError)], [UserProfile]) +lookupProfilesV3 self others = getUserProfilesWithErrors self others getLegalHoldStatus :: - Member GalleyProvider r => + Member GalleyAPIAccess r => UserId -> AppT r (Maybe UserLegalHoldStatus) getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) getLegalHoldStatus' :: - Member GalleyProvider r => + Member GalleyAPIAccess r => User -> Sem r UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus Just tid -> do - teamMember <- GalleyProvider.getTeamMember (userId user) tid + teamMember <- GalleyAPIAccess.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember -- | Find user accounts for a given identity, both activated and those @@ -1730,7 +1606,7 @@ phonePrefixDelete = liftSem . BlacklistPhonePrefixStore.delete phonePrefixInsert :: Member BlacklistPhonePrefixStore r => ExcludedPrefix -> (AppT r) () phonePrefixInsert = liftSem . BlacklistPhonePrefixStore.insert -userUnderE2EId :: Member GalleyProvider r => UserId -> Sem r Bool +userUnderE2EId :: Member GalleyAPIAccess r => UserId -> Sem r Bool userUnderE2EId uid = do wsStatus . afcMlsE2EId <$> getAllFeatureConfigsForUser (Just uid) <&> \case FeatureStatusEnabled -> True @@ -1743,7 +1619,7 @@ userUnderE2EId uid = do -- - comments in `testUpdateHandle` in `/integration`. -- -- FUTUREWORK: figure out a better way for clients to detect E2EId (V6?) -hackForBlockingHandleChangeForE2EIdTeams :: Member GalleyProvider r => SelfProfile -> Sem r SelfProfile +hackForBlockingHandleChangeForE2EIdTeams :: Member GalleyAPIAccess r => SelfProfile -> Sem r SelfProfile hackForBlockingHandleChangeForE2EIdTeams (SelfProfile user) = do hasE2EId <- userUnderE2EId . userId $ user pure . SelfProfile $ diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 4a25928751a..ad1a74c246a 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -32,7 +32,6 @@ module Brig.App closeEnv, awsEnv, smtpEnv, - stompEnv, cargohold, galley, galleyEndpoint, @@ -97,11 +96,12 @@ import Bilge.IO import Bilge.RPC (HasRequestId (..)) import Brig.AWS qualified as AWS import Brig.Calling qualified as Calling +import Brig.DeleteQueue.Interpreter import Brig.Options (ElasticSearchOpts, Opts, Settings (..)) import Brig.Options qualified as Opt import Brig.Provider.Template import Brig.Queue.Stomp qualified as Stomp -import Brig.Queue.Types (Queue (..)) +import Brig.Queue.Types import Brig.SMTP qualified as SMTP import Brig.Schema.Run qualified as Migrations import Brig.Team.Template @@ -172,10 +172,9 @@ data Env = Env _smtpEnv :: Maybe SMTP.SMTP, _emailSender :: Email, _awsEnv :: AWS.Env, - _stompEnv :: Maybe Stomp.Env, _metrics :: Metrics, _applog :: Logger, - _internalEvents :: Queue, + _internalEvents :: QueueEnv, _requestId :: RequestId, _usrTemplates :: Localised UserTemplates, _provTemplates :: Localised ProviderTemplates, @@ -240,16 +239,17 @@ newEnv o = do let sett = Opt.optSettings o nxm <- initCredentials (Opt.setNexmo sett) twl <- initCredentials (Opt.setTwilio sett) - stomp <- case (Opt.stomp o, Opt.setStomp sett) of - (Nothing, Nothing) -> pure Nothing - (Just s, Just c) -> Just . Stomp.mkEnv s <$> initCredentials c - (Just _, Nothing) -> error "STOMP is configured but 'setStomp' is not set" - (Nothing, Just _) -> error "'setStomp' is present but STOMP is not configured" - -- This is messy. See Note [queue refactoring] to learn how we - -- eventually plan to solve this mess. - eventsQueue <- case Opt.internalEventsQueue (Opt.internalEvents o) of - StompQueue q -> pure (StompQueue q) - SqsQueue q -> SqsQueue <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q + eventsQueue :: QueueEnv <- case Opt.internalEventsQueue (Opt.internalEvents o) of + StompQueueOpts q -> do + stomp :: Stomp.Env <- case (Opt.stomp o, Opt.setStomp sett) of + (Just s, Just c) -> Stomp.mkEnv s <$> initCredentials c + (Just _, Nothing) -> error "STOMP is configured but 'setStomp' is not set" + (Nothing, Just _) -> error "'setStomp' is present but STOMP is not configured" + (Nothing, Nothing) -> error "stomp is selected for internal events, but not configured in 'setStomp', STOMP" + pure (StompQueueEnv (Stomp.broker stomp) q) + SqsQueueOpts q -> do + let throttleMillis = fromMaybe Opt.defSqsThrottleMillis (view Opt.sqsThrottleMillis $ Opt.optSettings o) + SqsQueueEnv aws throttleMillis <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q mSFTEnv <- mapM (Calling.mkSFTEnv sha512) $ Opt.sft o prekeyLocalLock <- case Opt.randomPrekeys o of Just True -> do @@ -273,11 +273,10 @@ newEnv o = do _casClient = cas, _smtpEnv = emailSMTP, _emailSender = Opt.emailSender . Opt.general . Opt.emailSMS $ o, - _awsEnv = aws, - _stompEnv = stomp, + _awsEnv = aws, -- used by `journalEvent` directly _metrics = mtr, _applog = lgr, - _internalEvents = eventsQueue, + _internalEvents = (eventsQueue :: QueueEnv), _requestId = RequestId "N/A", _usrTemplates = utp, _provTemplates = ptp, diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index b23a8c2a6dc..f4ab597711e 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -1,6 +1,7 @@ module Brig.CanonicalInterpreter where -import Brig.App +import Brig.App as App +import Brig.DeleteQueue.Interpreter as DQ import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistPhonePrefixStore.Cassandra (interpretBlacklistPhonePrefixStoreToCassandra) import Brig.Effects.BlacklistStore (BlacklistStore) @@ -11,8 +12,6 @@ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider.RPC import Brig.Effects.JwtTools import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) @@ -22,23 +21,31 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) import Brig.Options (ImplicitNoFederationRestriction (federationDomainConfig), federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt -import Brig.RPC (ParseException) import Cassandra qualified as Cas -import Control.Lens ((^.)) +import Control.Exception (ErrorCall) +import Control.Lens (to, (^.)) import Control.Monad.Catch (throwM) import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports -import Polysemy (Embed, Final, embed, embedToFinal, runFinal) +import Polysemy import Polysemy.Async import Polysemy.Conc import Polysemy.Embed (runEmbedded) -import Polysemy.Error (Error, mapError, runError) +import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst, runInputSem) import Polysemy.TinyLog (TinyLog) +import Wire.API.Federation.Client qualified +import Wire.API.Federation.Error +import Wire.DeleteQueue +import Wire.FederationAPIAccess qualified +import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) +import Wire.ParseException import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO @@ -48,9 +55,18 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserStore +import Wire.UserStore.Cassandra +import Wire.UserSubsystem +import Wire.UserSubsystem.Interpreter type BrigCanonicalEffects = - '[ SFT, + '[ UserSubsystem, + DeleteQueue, + Error Wire.API.Federation.Error.FederationError, + Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, + UserStore, + SFT, ConnectionStore InternalPaging, Input UTCTime, Input (Local ()), @@ -67,10 +83,11 @@ type BrigCanonicalEffects = Now, Delay, CodeStore, - GalleyProvider, + GalleyAPIAccess, Rpc, Embed Cas.Client, Error ParseException, + Error ErrorCall, Error SomeException, TinyLog, Embed HttpClientIO, @@ -81,8 +98,20 @@ type BrigCanonicalEffects = Final IO ] -runBrigToIO :: Env -> AppT BrigCanonicalEffects a -> IO a +runBrigToIO :: App.Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = do + let userSubsystemConfig = + UserSubsystemConfig + { emailVisibilityConfig = e ^. settings . Opt.emailVisibility, + defaultLocale = e ^. settings . to Opt.setDefaultUserLocale + } + federationApiAccessConfig = + FederationAPIAccessConfig + { ownDomain = e ^. settings . Opt.federationDomain, + federatorEndpoint = e ^. federator, + http2Manager = e ^. App.http2Manager, + requestId = e ^. App.requestId + } ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency @@ -92,10 +121,11 @@ runBrigToIO e (AppT ma) = do . runEmbedded (runHttpClientIO e) . loggerToTinyLog (e ^. applog) . runError @SomeException + . mapError @ErrorCall SomeException . mapError @ParseException SomeException . interpretClientToIO (e ^. casClient) - . runRpcWithHttp (e ^. httpManager) (e ^. requestId) - . interpretGalleyProviderToRpc (e ^. disabledVersions) (e ^. galleyEndpoint) + . runRpcWithHttp (e ^. httpManager) (e ^. App.requestId) + . interpretGalleyAPIAccessToRpc (e ^. disabledVersions) (e ^. galleyEndpoint) . codeStoreToCassandra @Cas.Client . runDelay . nowToIOAction (e ^. currentTime) @@ -108,11 +138,23 @@ runBrigToIO e (AppT ma) = do . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) . runGundeckAPIAccess (e ^. gundeckEndpoint) - . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. requestId)) + . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. App.requestId)) . runInputConst (toLocalUnsafe (e ^. settings . Opt.federationDomain) ()) . runInputSem (embed getCurrentTime) . connectionStoreToCassandra . interpretSFT (e ^. httpManager) + . interpretUserStoreCassandra (e ^. casClient) + . interpretFederationAPIAccess federationApiAccessConfig + . throwFederationErrorAsWaiError + . runDeleteQueue (e ^. internalEvents) + . runUserSubsystem userSubsystemConfig ) ) $ runReaderT ma e + +throwFederationErrorAsWaiError :: Member (Final IO) r => InterpreterFor (Error FederationError) r +throwFederationErrorAsWaiError action = do + eithError <- errorToIOFinal action + case eithError of + Left err -> embedToFinal $ throwM $ federationErrorToWai err + Right a -> pure a diff --git a/services/brig/src/Brig/DeleteQueue/Interpreter.hs b/services/brig/src/Brig/DeleteQueue/Interpreter.hs new file mode 100644 index 00000000000..e55b7453ef5 --- /dev/null +++ b/services/brig/src/Brig/DeleteQueue/Interpreter.hs @@ -0,0 +1,72 @@ +module Brig.DeleteQueue.Interpreter + ( runDeleteQueue, + QueueEnv (..), + ) +where + +import Amazonka.SQS.Lens +import Brig.AWS qualified as AWS +import Brig.Queue.Stomp qualified as Stomp +import Control.Exception (ErrorCall (..)) +import Control.Lens +import Data.Aeson +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Lazy qualified as BL +import Data.Text as T +import Data.Text.Encoding qualified as T +import Imports +import OpenSSL.EVP.Digest hiding (digest) +import Polysemy +import Polysemy.Error +import System.Logger.Class qualified as Log +import Wire.DeleteQueue +import Wire.InternalEvent +import Wire.Sem.Logger + +-- | The queue environment constructed from `QueueOpts`. +data QueueEnv + = StompQueueEnv Stomp.Broker Text + | SqsQueueEnv AWS.Env Int Text + +runDeleteQueue :: + ( Member (Embed IO) r, + Member (Logger (Log.Msg -> Log.Msg)) r, + Member (Error ErrorCall) r + ) => + QueueEnv -> + InterpreterFor DeleteQueue r +runDeleteQueue queueEnv = + interpret $ \case + EnqueueUserDeletion userId -> enqueue queueEnv (DeleteUser userId) + EnqueueClientDeletion clientId userId mConnId -> enqueue queueEnv (DeleteClient clientId userId mConnId) + EnqueueServiceDeletion providerId serviceId -> enqueue queueEnv (DeleteService providerId serviceId) + +-- | Enqueue a message. +-- +-- Throws an error in case of failure. +enqueue :: + ( Member (Embed IO) r, + Member (Logger (Log.Msg -> Log.Msg)) r, + Member (Error ErrorCall) r + ) => + ToJSON a => + QueueEnv -> + a -> + Sem r () +enqueue (StompQueueEnv broker queue) message = + embed @IO $ Stomp.enqueue broker queue message +enqueue (SqsQueueEnv awsEnv _ queue) message = do + let body = encode message + md5 <- embed @IO $ getDigestByName "MD5" + let bodyMD5 = fmap (flip digest body) md5 + resp <- embed @IO $ AWS.execute awsEnv (AWS.enqueueStandard queue body) + unless (resp ^. sendMessageResponse_mD5OfMessageBody == bodyMD5) $ do + err $ + Log.msg (Log.val "Returned hash (MD5) doesn't match message hash") + . Log.field "SqsQueue" (show queue) + . Log.field "returned_hash" (show (resp ^. sendMessageResponse_mD5OfMessageBody)) + . Log.field "message_hash" (show (Just bodyMD5)) + throw (ErrorCall "The server couldn't access a queue") + where + digest :: Digest -> BL.ByteString -> Text + digest d = T.decodeLatin1 . B16.encode . digestLBS d diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index d5faf53332c..274a784092c 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -61,6 +61,8 @@ userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing journalEvent :: (MonadReader Env m, MonadIO m) => UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> m () journalEvent typ uid em loc tid nm = + -- this may be the only place that uses awsEnv from brig Env. refactor it to use the + -- DeleteQueue effect instead? view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do ts <- now rnd <- liftIO nextRandom diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index c27fd4cd821..d837fb7a2f4 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -24,7 +24,7 @@ module Brig.Options where import Brig.Allowlists (AllowlistEmailDomains (..), AllowlistPhonePrefixes (..)) -import Brig.Queue.Types (Queue (..)) +import Brig.Queue.Types (QueueOpts (..)) import Brig.SMTP (SMTPConnType (..)) import Brig.User.Auth.Cookie.Limit import Brig.ZAuth qualified as ZAuth @@ -165,7 +165,7 @@ data StompOpts = StompOpts instance FromJSON StompOpts data InternalEventsOpts = InternalEventsOpts - { internalEventsQueue :: !Queue + { internalEventsQueue :: !QueueOpts } deriving (Show) diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index c59e561e4cb..56587b0d68f 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -38,17 +38,13 @@ import Brig.App import Brig.Code qualified as Code import Brig.Data.Client qualified as User import Brig.Data.User qualified as User -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Email (mkEmailKey) -import Brig.InternalEvent.Types qualified as Internal import Brig.Options (Settings (..)) import Brig.Options qualified as Opt import Brig.Provider.DB (ServiceConn (..)) import Brig.Provider.DB qualified as DB import Brig.Provider.Email import Brig.Provider.RPC qualified as RPC -import Brig.Queue qualified as Queue import Brig.Team.Util import Brig.Types.User import Brig.ZAuth qualified as ZAuth @@ -123,11 +119,15 @@ import Wire.API.User.Client import Wire.API.User.Client qualified as Public (Client, ClientCapability (ClientSupportsLegalholdImplicitConsent), PubClient (..), UserClientPrekeyMap, UserClients, userClients) import Wire.API.User.Client.Prekey qualified as Public (PrekeyId) import Wire.API.User.Identity qualified as Public (Email) +import Wire.DeleteQueue +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) botAPI :: - ( Member GalleyProvider r, - Member (Concurrency 'Unsafe) r + ( Member GalleyAPIAccess r, + Member (Concurrency 'Unsafe) r, + Member DeleteQueue r ) => ServerT BotAPI (Handler r) botAPI = @@ -143,7 +143,9 @@ botAPI = :<|> Named @"bot-list-users" botListUserProfiles :<|> Named @"bot-get-user-clients" botGetUserClients -servicesAPI :: (Member GalleyProvider r) => ServerT ServicesAPI (Handler r) +servicesAPI :: + (Member GalleyAPIAccess r, Member DeleteQueue r) => + ServerT ServicesAPI (Handler r) servicesAPI = Named @"post-provider-services" addService :<|> Named @"get-provider-services" listServices @@ -158,7 +160,7 @@ servicesAPI = :<|> Named @"get-whitelisted-services-by-team-id" searchTeamServiceProfiles :<|> Named @"post-team-whitelist-by-team-id" updateServiceWhitelist -providerAPI :: Member GalleyProvider r => ServerT ProviderAPI (Handler r) +providerAPI :: Member GalleyAPIAccess r => ServerT ProviderAPI (Handler r) providerAPI = Named @"provider-register" newAccount :<|> Named @"provider-activate" activateAccountKey @@ -172,13 +174,13 @@ providerAPI = :<|> Named @"provider-get-account" getAccount :<|> Named @"provider-get-profile" getProviderProfile -internalProviderAPI :: Member GalleyProvider r => ServerT BrigIRoutes.ProviderAPI (Handler r) +internalProviderAPI :: Member GalleyAPIAccess r => ServerT BrigIRoutes.ProviderAPI (Handler r) internalProviderAPI = Named @"get-provider-activation-code" getActivationCodeH -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccount :: Member GalleyProvider r => Public.NewProvider -> (Handler r) Public.NewProviderResponse +newAccount :: Member GalleyAPIAccess r => Public.NewProvider -> (Handler r) Public.NewProviderResponse newAccount new = do guardSecondFactorDisabled Nothing email <- case validateEmail (Public.newProviderEmail new) of @@ -211,7 +213,7 @@ newAccount new = do lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKey :: Member GalleyProvider r => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) +activateAccountKey :: Member GalleyAPIAccess r => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do guardSecondFactorDisabled Nothing c <- wrapClientE (Code.verify key Code.IdentityVerification val) >>= maybeInvalidCode @@ -234,7 +236,7 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Member GalleyProvider r => Public.Email -> (Handler r) Code.KeyValuePair +getActivationCodeH :: Member GalleyAPIAccess r => Public.Email -> (Handler r) Code.KeyValuePair getActivationCodeH e = do guardSecondFactorDisabled Nothing email <- case validateEmail e of @@ -244,7 +246,7 @@ getActivationCodeH e = do code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification maybe (throwStd activationKeyNotFound) (pure . Code.codeToKeyValuePair) code -login :: Member GalleyProvider r => ProviderLogin -> Handler r ProviderTokenCookie +login :: Member GalleyAPIAccess r => ProviderLogin -> Handler r ProviderTokenCookie login l = do guardSecondFactorDisabled Nothing pid <- wrapClientE (DB.lookupKey (mkEmailKey (providerLoginEmail l))) >>= maybeBadCredentials @@ -255,7 +257,7 @@ login l = do s <- view settings pure $ ProviderTokenCookie (ProviderToken token) (not (setCookieInsecure s)) -beginPasswordReset :: Member GalleyProvider r => Public.PasswordReset -> (Handler r) () +beginPasswordReset :: Member GalleyAPIAccess r => Public.PasswordReset -> (Handler r) () beginPasswordReset (Public.PasswordReset target) = do guardSecondFactorDisabled Nothing pid <- wrapClientE (DB.lookupKey (mkEmailKey target)) >>= maybeBadCredentials @@ -273,7 +275,7 @@ beginPasswordReset (Public.PasswordReset target) = do tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) -completePasswordReset :: Member GalleyProvider r => Public.CompletePasswordReset -> (Handler r) () +completePasswordReset :: Member GalleyAPIAccess r => Public.CompletePasswordReset -> (Handler r) () completePasswordReset (Public.CompletePasswordReset key val newpwd) = do guardSecondFactorDisabled Nothing code <- wrapClientE (Code.verify key Code.PasswordReset val) >>= maybeInvalidCode @@ -290,12 +292,12 @@ completePasswordReset (Public.CompletePasswordReset key val newpwd) = do -------------------------------------------------------------------------------- -- Provider API -getAccount :: Member GalleyProvider r => ProviderId -> (Handler r) (Maybe Public.Provider) +getAccount :: Member GalleyAPIAccess r => ProviderId -> (Handler r) (Maybe Public.Provider) getAccount pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.lookupAccount pid -updateAccountProfile :: Member GalleyProvider r => ProviderId -> Public.UpdateProvider -> (Handler r) () +updateAccountProfile :: Member GalleyAPIAccess r => ProviderId -> Public.UpdateProvider -> (Handler r) () updateAccountProfile pid upd = do guardSecondFactorDisabled Nothing _ <- wrapClientE (DB.lookupAccount pid) >>= maybeInvalidProvider @@ -306,7 +308,7 @@ updateAccountProfile pid upd = do (updateProviderUrl upd) (updateProviderDescr upd) -updateAccountEmail :: Member GalleyProvider r => ProviderId -> Public.EmailUpdate -> (Handler r) () +updateAccountEmail :: Member GalleyAPIAccess r => ProviderId -> Public.EmailUpdate -> (Handler r) () updateAccountEmail pid (Public.EmailUpdate new) = do guardSecondFactorDisabled Nothing email <- case validateEmail new of @@ -325,7 +327,7 @@ updateAccountEmail pid (Public.EmailUpdate new) = do tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True -updateAccountPassword :: Member GalleyProvider r => ProviderId -> Public.PasswordChange -> (Handler r) () +updateAccountPassword :: Member GalleyAPIAccess r => ProviderId -> Public.PasswordChange -> (Handler r) () updateAccountPassword pid upd = do guardSecondFactorDisabled Nothing pass <- wrapClientE (DB.lookupPassword pid) >>= maybeBadCredentials @@ -336,7 +338,7 @@ updateAccountPassword pid upd = do wrapClientE $ DB.updateAccountPassword pid (newPassword upd) addService :: - Member GalleyProvider r => + Member GalleyAPIAccess r => ProviderId -> Public.NewService -> (Handler r) Public.NewServiceResponse @@ -356,13 +358,13 @@ addService pid new = do let rstoken = maybe (Just token) (const Nothing) (newServiceToken new) pure $ Public.NewServiceResponse sid rstoken -listServices :: Member GalleyProvider r => ProviderId -> (Handler r) [Public.Service] +listServices :: Member GalleyAPIAccess r => ProviderId -> (Handler r) [Public.Service] listServices pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.listServices pid getService :: - Member GalleyProvider r => + Member GalleyAPIAccess r => ProviderId -> ServiceId -> (Handler r) Public.Service @@ -371,7 +373,7 @@ getService pid sid = do wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound updateService :: - Member GalleyProvider r => + Member GalleyAPIAccess r => ProviderId -> ServiceId -> Public.UpdateService -> @@ -405,7 +407,7 @@ updateService pid sid upd = do (serviceEnabled svc) updateServiceConn :: - Member GalleyProvider r => + Member GalleyAPIAccess r => ProviderId -> ServiceId -> Public.UpdateServiceConn -> @@ -452,7 +454,9 @@ updateServiceConn pid sid upd = do -- disabled and then creates an event that will, when processed, actually -- delete the service. See 'finishDeleteService'. deleteService :: - Member GalleyProvider r => + ( Member GalleyAPIAccess r, + Member DeleteQueue r + ) => ProviderId -> ServiceId -> Public.DeleteService -> @@ -467,8 +471,7 @@ deleteService pid sid del = do -- Disable the service wrapClientE $ DB.updateServiceConn pid sid Nothing Nothing Nothing (Just False) -- Create an event - queue <- view internalEvents - lift $ Queue.enqueue queue (Internal.DeleteService pid sid) + lift . liftSem $ enqueueServiceDeletion pid sid finishDeleteService :: ( MonadReader Env m, @@ -496,7 +499,7 @@ finishDeleteService pid sid = do kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid deleteAccount :: - ( Member GalleyProvider r + ( Member GalleyAPIAccess r ) => ProviderId -> Public.DeleteProvider -> @@ -521,17 +524,17 @@ deleteAccount pid del = do -------------------------------------------------------------------------------- -- User API -getProviderProfile :: Member GalleyProvider r => UserId -> ProviderId -> (Handler r) (Maybe Public.ProviderProfile) +getProviderProfile :: Member GalleyAPIAccess r => UserId -> ProviderId -> (Handler r) (Maybe Public.ProviderProfile) getProviderProfile _ pid = do guardSecondFactorDisabled Nothing wrapClientE (DB.lookupAccountProfile pid) -listServiceProfiles :: Member GalleyProvider r => UserId -> ProviderId -> (Handler r) [Public.ServiceProfile] +listServiceProfiles :: Member GalleyAPIAccess r => UserId -> ProviderId -> (Handler r) [Public.ServiceProfile] listServiceProfiles _ pid = do guardSecondFactorDisabled Nothing wrapClientE $ DB.listServiceProfiles pid -getServiceProfile :: Member GalleyProvider r => UserId -> ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile +getServiceProfile :: Member GalleyAPIAccess r => UserId -> ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile getServiceProfile _ pid sid = do guardSecondFactorDisabled Nothing wrapClientE (DB.lookupServiceProfile pid sid) >>= maybeServiceNotFound @@ -540,7 +543,7 @@ getServiceProfile _ pid sid = do -- pagination here, we need both 'start' and 'prefix'. -- -- Also see Note [buggy pagination]. -searchServiceProfiles :: Member GalleyProvider r => UserId -> Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Maybe (Range 10 100 Int32) -> (Handler r) Public.ServiceProfilePage +searchServiceProfiles :: Member GalleyAPIAccess r => UserId -> Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Maybe (Range 10 100 Int32) -> (Handler r) Public.ServiceProfilePage searchServiceProfiles _ Nothing (Just start) mSize = do guardSecondFactorDisabled Nothing prefix :: Range 1 128 Text <- rangeChecked start @@ -574,14 +577,14 @@ searchTeamServiceProfiles uid tid prefix mFilterDisabled mSize = do -- Get search results wrapClientE $ DB.paginateServiceWhitelist tid prefix filterDisabled (fromRange size) -getServiceTagList :: Member GalleyProvider r => UserId -> (Handler r) Public.ServiceTagList +getServiceTagList :: Member GalleyAPIAccess r => UserId -> (Handler r) Public.ServiceTagList getServiceTagList _ = do guardSecondFactorDisabled Nothing pure (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelist :: Member GalleyProvider r => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp +updateServiceWhitelist :: Member GalleyAPIAccess r => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do guardSecondFactorDisabled (Just uid) let pid = updateServiceWhitelistProvider upd @@ -618,7 +621,7 @@ updateServiceWhitelist uid con tid upd = do -------------------------------------------------------------------------------- -- Bot API -addBot :: Member GalleyProvider r => UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse +addBot :: Member GalleyAPIAccess r => UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse addBot zuid zcon cid add = do guardSecondFactorDisabled (Just zuid) zusr <- lift (wrapClient $ User.lookupUser NoPendingInvitations zuid) >>= maybeInvalidUser @@ -626,7 +629,7 @@ addBot zuid zcon cid add = do let sid = addBotService add -- Get the conversation and check preconditions lcid <- qualifyLocal cid - cnv <- lift (liftSem $ GalleyProvider.getConv zuid lcid) >>= maybeConvNotFound + cnv <- lift (liftSem $ GalleyAPIAccess.getConv zuid lcid) >>= maybeConvNotFound -- Check that the user is a conversation admin and therefore is allowed to add a bot to this conversation. -- Note that this precondition is also checked in the internal galley API, -- but by having this check here we prevent any (useless) data to be written to the database @@ -702,12 +705,12 @@ addBot zuid zcon cid add = do Public.rsAddBotEvent = ev } -removeBot :: Member GalleyProvider r => UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) +removeBot :: Member GalleyAPIAccess r => UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) removeBot zusr zcon cid bid = do guardSecondFactorDisabled (Just zusr) -- Get the conversation and check preconditions lcid <- qualifyLocal cid - cnv <- lift (liftSem $ GalleyProvider.getConv zusr lcid) >>= maybeConvNotFound + cnv <- lift (liftSem $ GalleyAPIAccess.getConv zusr lcid) >>= maybeConvNotFound -- Check that the user is a conversation admin and therefore is allowed to remove a bot from the conversation. -- Note that this precondition is also checked in the internal galley API. -- However, in case we refine the roles model in the future, this check might not be granular enough. @@ -735,12 +738,12 @@ botGetSelf bot = do p <- lift $ wrapClient $ User.lookupUser NoPendingInvitations (botUserId bot) maybe (throwStd (errorToWai @'E.UserNotFound)) (\u -> pure $ Public.mkUserProfile EmailVisibleToSelf u UserLegalHoldNoConsent) p -botGetClient :: Member GalleyProvider r => BotId -> (Handler r) (Maybe Public.Client) +botGetClient :: Member GalleyAPIAccess r => BotId -> (Handler r) (Maybe Public.Client) botGetClient bot = do guardSecondFactorDisabled (Just (botUserId bot)) lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) -botListPrekeys :: Member GalleyProvider r => BotId -> (Handler r) [Public.PrekeyId] +botListPrekeys :: Member GalleyAPIAccess r => BotId -> (Handler r) [Public.PrekeyId] botListPrekeys bot = do guardSecondFactorDisabled (Just (botUserId bot)) clt <- lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) @@ -748,7 +751,7 @@ botListPrekeys bot = do Nothing -> pure [] Just ci -> lift (wrapClient $ User.lookupPrekeyIds (botUserId bot) ci) -botUpdatePrekeys :: Member GalleyProvider r => BotId -> Public.UpdateBotPrekeys -> (Handler r) () +botUpdatePrekeys :: Member GalleyAPIAccess r => BotId -> Public.UpdateBotPrekeys -> (Handler r) () botUpdatePrekeys bot upd = do guardSecondFactorDisabled (Just (botUserId bot)) clt <- lift $ listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) @@ -759,7 +762,10 @@ botUpdatePrekeys bot upd = do wrapClientE (User.updatePrekeys (botUserId bot) (clientId c) pks) !>> clientDataError botClaimUsersPrekeys :: - (Member (Concurrency 'Unsafe) r, Member GalleyProvider r) => + ( Member (Concurrency 'Unsafe) r, + Member GalleyAPIAccess r, + Member DeleteQueue r + ) => BotId -> Public.UserClients -> Handler r Public.UserClientPrekeyMap @@ -770,20 +776,20 @@ botClaimUsersPrekeys _ body = do throwStd (errorToWai @'E.TooManyClients) Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError -botListUserProfiles :: Member GalleyProvider r => BotId -> (CommaSeparatedList UserId) -> (Handler r) [Public.BotUserView] +botListUserProfiles :: Member GalleyAPIAccess r => BotId -> (CommaSeparatedList UserId) -> (Handler r) [Public.BotUserView] botListUserProfiles _ uids = do guardSecondFactorDisabled Nothing -- should we check all user ids? us <- lift . wrapClient $ User.lookupUsers NoPendingInvitations (fromCommaSeparatedList uids) pure (map mkBotUserView us) -botGetUserClients :: Member GalleyProvider r => BotId -> UserId -> (Handler r) [Public.PubClient] +botGetUserClients :: Member GalleyAPIAccess r => BotId -> UserId -> (Handler r) [Public.PubClient] botGetUserClients _ uid = do guardSecondFactorDisabled (Just uid) lift $ pubClient <$$> wrapClient (User.lookupClients uid) where pubClient c = Public.PubClient (clientId c) (clientClass c) -botDeleteSelf :: Member GalleyProvider r => BotId -> ConvId -> (Handler r) () +botDeleteSelf :: Member GalleyAPIAccess r => BotId -> ConvId -> (Handler r) () botDeleteSelf bid cid = do guardSecondFactorDisabled (Just (botUserId bid)) bot <- lift . wrapClient $ User.lookupUser NoPendingInvitations (botUserId bid) @@ -797,11 +803,11 @@ botDeleteSelf bid cid = do -- | If second factor auth is enabled, make sure that end-points that don't support it, but should, are blocked completely. -- (This is a workaround until we have 2FA for those end-points as well.) guardSecondFactorDisabled :: - Member GalleyProvider r => + Member GalleyAPIAccess r => Maybe UserId -> ExceptT Error (AppT r) () guardSecondFactorDisabled mbUserId = do - enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> GalleyProvider.getAllFeatureConfigsForUser mbUserId + enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId when enabled $ (throwStd (errorToWai @'E.AccessDenied)) minRsaKeySize :: Int diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 98670483b73..12e17007518 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -57,6 +57,7 @@ import Wire.API.Event.Conversation qualified as Conv import Wire.API.Provider (httpsUrl) import Wire.API.Provider.External import Wire.API.Provider.Service qualified as Galley +import Wire.ParseException import Wire.Rpc -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index 2385631f7b4..a5e7d4d275b 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -26,7 +26,7 @@ where import Amazonka.SQS.Lens (sendMessageResponse_mD5OfMessageBody) import Brig.AWS qualified as AWS import Brig.App -import Brig.Options +import Brig.DeleteQueue.Interpreter (QueueEnv (..)) import Brig.Queue.Stomp qualified as Stomp import Brig.Queue.Types import Control.Exception (ErrorCall (..)) @@ -43,22 +43,12 @@ import System.Logger.Class as Log hiding (settings) -- Note [queue refactoring] -- ~~~~~~~~~~~~~~~~ -- --- The way we deal with queues is not the best. There are two pieces of +-- 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. --- --- 2. If the 'Queue' is an SqsQueue, it has to be "resolved" before it can --- be used (we do that in 'newEnv', for instance). Ideally the 'Queue' --- should be a self-contained reference to a queue, with no 'Broker' or --- 'Stomp.Env' needed to use it; we can still have 'Stomp.Env' in our --- configs, but it should disappear after the config is read. --- Similarly, for SqsQueues we should store the queue URL in the --- config, and not queue name, because AWS documentation suggests that --- the URL should actually be considered the canonical queue --- identifier. -- | Enqueue a message. -- @@ -70,29 +60,22 @@ enqueue :: MonadLogger m, MonadThrow m ) => - Queue -> + QueueEnv -> a -> m () -enqueue (StompQueue queue) message = - view stompEnv >>= \case - Just env -> Stomp.enqueue (Stomp.broker env) queue message - Nothing -> do - Log.err $ - msg (val "Tried to publish a message but STOMP is not configured") - . field "StompQueue" (show queue) - throwM (ErrorCall "The server couldn't access a queue") -enqueue (SqsQueue queue) message = - view awsEnv >>= \env -> 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") +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 @@ -106,22 +89,13 @@ listen :: ( Show a, FromJSON a, MonadLogger m, - MonadReader Env m, MonadMask m, MonadUnliftIO m ) => - Queue -> + QueueEnv -> (a -> m ()) -> m () -listen (StompQueue queue) callback = - view stompEnv >>= \case - Just env -> Stomp.listen (Stomp.broker env) queue callback - Nothing -> do - Log.err $ - msg (val "Can't listen on a queue because STOMP is not configured") - . field "StompQueue" (show queue) - throwM (ErrorCall "The server couldn't access a queue") -listen (SqsQueue queue) callback = do - env <- ask - throttleMillis <- fromMaybe defSqsThrottleMillis <$> view (settings . sqsThrottleMillis) - withRunInIO $ \lower -> AWS.execute (env ^. awsEnv) $ AWS.listen throttleMillis queue $ lower . callback +listen (StompQueueEnv env queue) callback = + Stomp.listen env queue callback +listen (SqsQueueEnv env throttleMillis queue) callback = do + withRunInIO $ \lower -> AWS.execute env $ AWS.listen throttleMillis queue $ lower . callback diff --git a/services/brig/src/Brig/Queue/Types.hs b/services/brig/src/Brig/Queue/Types.hs index 4f517ab7202..e7784b8b8fe 100644 --- a/services/brig/src/Brig/Queue/Types.hs +++ b/services/brig/src/Brig/Queue/Types.hs @@ -16,20 +16,20 @@ -- with this program. If not, see . module Brig.Queue.Types - ( Queue (..), + ( QueueOpts (..), ) where import Data.Aeson import Imports --- | A remote queue that you can publish to and listen from. -data Queue = StompQueue Text | SqsQueue Text +-- | Config file info for a remote queue that you can publish to and listen from. +data QueueOpts = StompQueueOpts Text | SqsQueueOpts Text deriving (Eq, Show) -instance FromJSON Queue where +instance FromJSON QueueOpts where parseJSON = withObject "Queue" $ \o -> o .: "queueType" >>= \case - "stomp" -> StompQueue <$> o .: "queueName" - "sqs" -> SqsQueue <$> o .: "queueName" + "stomp" -> StompQueueOpts <$> o .: "queueName" + "sqs" -> SqsQueueOpts <$> o .: "queueName" other -> fail ("unknown 'queueType': " <> other) diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 9ab6d97c660..c421ad468d2 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -27,11 +27,11 @@ import Control.Monad.Catch import Control.Retry import Data.Aeson import Data.ByteString.Lazy qualified as BL -import Data.Text qualified as Text import Data.Text.Lazy qualified as LT import Imports import Network.HTTP.Types.Method import System.Logger.Class hiding (name, (.=)) +import Wire.ParseException import Wire.Rpc (x3) remote :: ByteString -> Msg -> Msg @@ -76,18 +76,3 @@ serviceRequestImpl nm service m r = do recovering x3 rpcHandlers $ const $ rpc' nm service (method m . r) - --- | Failed to parse a response from another service. -data ParseException = ParseException - { _parseExceptionRemote :: !Text, - _parseExceptionMsg :: String - } - -instance Show ParseException where - show (ParseException r m) = - "Failed to parse response from remote " - ++ Text.unpack r - ++ " with message: " - ++ m - -instance Exception ParseException diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index e7219fef819..35f3fd36efa 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -76,6 +76,7 @@ import Wire.API.Routes.Public.Brig import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) +import Wire.DeleteQueue import Wire.Sem.Paging qualified as P -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -186,7 +187,16 @@ bodyParserErrorFormatter _ _ errMsg = Servant.errHeaders = [(HTTP.hContentType, HTTPMedia.renderHeader (Servant.contentType (Proxy @Servant.JSON)))] } -pendingActivationCleanup :: forall r p. (P.Paging p, Member (UserPendingActivationStore p) r) => AppT r () +-- | Go through expired pending activations/invitations and delete them. This could probably +-- be done with cassandra TTLs, but it involves several tables and may require adjusting their +-- write operations. +pendingActivationCleanup :: + forall r p. + ( P.Paging p, + Member (UserPendingActivationStore p) r, + Member DeleteQueue r + ) => + AppT r () pendingActivationCleanup = do safeForever "pendingActivationCleanup" $ do now <- liftIO =<< view currentTime diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index c14ac164d13..46ce343f9e4 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -37,15 +37,12 @@ import Brig.Data.UserKey qualified as Data import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore qualified as BlacklistStore import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Email qualified as Email import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import Brig.Phone qualified as Phone import Brig.Team.DB qualified as DB import Brig.Team.Email -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize @@ -83,13 +80,15 @@ import Wire.API.Team.Role import Wire.API.Team.Role qualified as Public import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public +import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) servantAPI :: ( Member BlacklistStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -101,7 +100,7 @@ servantAPI = :<|> Named @"head-team-invitations" headInvitationByEmail :<|> Named @"get-team-size" teamSizePublic -teamSizePublic :: Member GalleyProvider r => UserId -> TeamId -> (Handler r) TeamSize +teamSizePublic :: Member GalleyAPIAccess r => UserId -> TeamId -> (Handler r) TeamSize teamSizePublic uid tid = do ensurePermissions uid tid [AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks teamSize tid @@ -116,7 +115,7 @@ getInvitationCode t r = do createInvitationPublicH :: ( Member BlacklistStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => UserId -> TeamId -> @@ -138,7 +137,7 @@ data CreateInvitationInviter = CreateInvitationInviter createInvitationPublic :: ( Member BlacklistStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => UserId -> TeamId -> @@ -165,7 +164,7 @@ createInvitationPublic uid tid body = do createInvitationViaScim :: ( Member BlacklistStore r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member TinyLog r ) => @@ -215,7 +214,7 @@ logInvitationRequest context action = createInvitation' :: ( Member BlacklistStore r, - Member GalleyProvider r + Member GalleyAPIAccess r ) => TeamId -> Maybe UserId -> @@ -256,7 +255,7 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do let locale = irLocale body let inviteeName = irInviteeName body - showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid lift $ do iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid @@ -277,22 +276,22 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do timeout (newInv, code) <$ sendInvitationMail inviteeEmail tid fromEmail code locale -deleteInvitation :: Member GalleyProvider r => UserId -> TeamId -> InvitationId -> (Handler r) () +deleteInvitation :: Member GalleyAPIAccess r => UserId -> TeamId -> InvitationId -> (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] lift $ wrapClient $ DB.deleteInvitation tid iid -listInvitations :: Member GalleyProvider r => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList +listInvitations :: Member GalleyAPIAccess r => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList listInvitations uid tid start mSize = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start (fromMaybe (unsafeRange 100) mSize) pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) -getInvitation :: Member GalleyProvider r => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) +getInvitation :: Member GalleyAPIAccess r => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid lift $ wrapClient $ DB.lookupInvitation showInvitationUrl tid iid getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation @@ -321,7 +320,7 @@ suspendTeam :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -333,14 +332,14 @@ suspendTeam tid = do Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) changeTeamAccountStatuses tid Suspended lift $ wrapClient $ DB.deleteInvitations tid - lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Suspended Nothing + lift $ liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing pure NoContent unsuspendTeam :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -350,7 +349,7 @@ unsuspendTeam :: (Handler r) NoContent unsuspendTeam tid = do changeTeamAccountStatuses tid Active - lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Active Nothing + lift $ liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Active Nothing pure NoContent ------------------------------------------------------------------------------- @@ -360,7 +359,7 @@ changeTeamAccountStatuses :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r, + Member GalleyAPIAccess r, Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -370,10 +369,10 @@ changeTeamAccountStatuses :: AccountStatus -> (Handler r) () changeTeamAccountStatuses tid s = do - team <- Team.tdTeam <$> lift (liftSem $ GalleyProvider.getTeam tid) + team <- Team.tdTeam <$> lift (liftSem $ GalleyAPIAccess.getTeam tid) unless (team ^. teamBinding == Binding) $ throwStd noBindingTeam - uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> liftSem (GalleyProvider.getTeamMembers tid)) + uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> liftSem (GalleyAPIAccess.getTeamMembers tid)) API.changeAccountStatus uids s !>> accountStatusError where toList1 (x : xs) = pure $ List1.list1 x xs diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 97db9efcded..ec22f1f6d81 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -41,7 +41,6 @@ import Brig.App as App import Brig.Data.Types as T import Brig.Options import Brig.Team.Template -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Template (renderTextWithBranding) import Cassandra as C import Control.Lens (view) @@ -63,6 +62,7 @@ import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Team.Invitation hiding (HeadInvitationByEmailResult (..)) import Wire.API.Team.Role import Wire.API.User +import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl (..)) mkInvitationCode :: IO InvitationCode mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 diff --git a/services/brig/src/Brig/Team/Types.hs b/services/brig/src/Brig/Team/Types.hs deleted file mode 100644 index e85bc4eb5b8..00000000000 --- a/services/brig/src/Brig/Team/Types.hs +++ /dev/null @@ -1,23 +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 . - -module Brig.Team.Types where - -import Imports - -data ShowOrHideInvitationUrl = ShowInvitationUrl | HideInvitationUrl - deriving (Eq, Show) diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 96669f4c9d6..bf7a3d0da85 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -20,8 +20,6 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App import Brig.Data.User qualified as Data -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error import Control.Lens @@ -32,18 +30,20 @@ import Polysemy (Member) import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User (User (userTeam)) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -- | If the user is in a team, it has to have these permissions. If not, it is a personal -- user with account validation and thus given the permission implicitly. (Used for -- `SearchContactcs`.) -ensurePermissionsOrPersonalUser :: (Member GalleyProvider r, IsPerm perm) => UserId -> [perm] -> ExceptT Error (AppT r) () +ensurePermissionsOrPersonalUser :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> [perm] -> ExceptT Error (AppT r) () ensurePermissionsOrPersonalUser u perms = do mbUser <- lift $ wrapHttp $ Data.lookupUser NoPendingInvitations u maybe (pure ()) (\tid -> ensurePermissions u tid perms) (userTeam =<< mbUser :: Maybe TeamId) -ensurePermissions :: (Member GalleyProvider r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT Error (AppT r) () +ensurePermissions :: (Member GalleyAPIAccess r, IsPerm perm) => UserId -> TeamId -> [perm] -> ExceptT Error (AppT r) () ensurePermissions u t perms = do - m <- lift $ liftSem $ GalleyProvider.getTeamMember u t + m <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t unless (check m) $ throwStd insufficientTeamPermissions where @@ -54,9 +54,9 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: Member GalleyProvider r => UserId -> TeamId -> Permissions -> ExceptT Error (AppT r) () +ensurePermissionToAddUser :: Member GalleyAPIAccess r => UserId -> TeamId -> Permissions -> ExceptT Error (AppT r) () ensurePermissionToAddUser u t inviteePerms = do - minviter <- lift $ liftSem $ GalleyProvider.getTeamMember u t + minviter <- lift $ liftSem $ GalleyAPIAccess.getTeamMember u t unless (check minviter) $ throwStd insufficientTeamPermissions where diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index a554b61f0f6..f39fa56a7b0 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -28,7 +28,6 @@ import Brig.API.Handler (Handler) import Brig.API.User qualified as API import Brig.App import Brig.Data.User qualified as Data -import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Federation.Client qualified as Federation import Brig.Options (searchSameTeamOnly) import Control.Lens (view) @@ -43,9 +42,10 @@ import Wire.API.User import Wire.API.User qualified as Public import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.UserSubsystem getHandleInfo :: - (Member GalleyProvider r) => + (Member UserSubsystem r) => UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) @@ -65,7 +65,7 @@ getRemoteHandleInfo handle = do Federation.getUserHandleInfo handle !>> fedError getLocalHandleInfo :: - (Member GalleyProvider r) => + (Member UserSubsystem r) => Local UserId -> Handle -> (Handler r) (Maybe Public.UserProfile) @@ -76,7 +76,9 @@ getLocalHandleInfo self handle = do Nothing -> pure Nothing Just ownerId -> do domain <- viewFederationDomain - ownerProfile <- API.lookupProfile self (Qualified ownerId domain) !>> fedError + ownerProfile <- + (lift . liftSem $ getUserProfile self (Qualified ownerId domain)) + !>> fedError owner <- filterHandleResults self (maybeToList ownerProfile) pure $ listToMaybe owner diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 14035f1e804..2d77a5e9119 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -30,8 +30,6 @@ import Brig.App import Brig.Data.User qualified as DB import Brig.Effects.FederationConfigStore import Brig.Effects.FederationConfigStore qualified as E -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Federation.Client qualified as Federation import Brig.Options qualified as Opts import Brig.Team.Util (ensurePermissions, ensurePermissionsOrPersonalUser) @@ -59,12 +57,16 @@ import Wire.API.Team.Permission qualified as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility (..)) import Wire.API.User.Search import Wire.API.User.Search qualified as Public +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.UserSubsystem -- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles -- for all results. This is tracked in https://wearezeta.atlassian.net/browse/SQCORE-599 search :: - ( Member GalleyProvider r, - Member FederationConfigStore r + ( Member GalleyAPIAccess r, + Member FederationConfigStore r, + Member UserSubsystem r ) => UserId -> Text -> @@ -113,7 +115,9 @@ searchRemotely domain mTid searchTerm = do searchLocally :: forall r. - (Member GalleyProvider r) => + ( Member GalleyAPIAccess r, + Member UserSubsystem r + ) => UserId -> Text -> Maybe (Range 1 500 Int32) -> @@ -156,7 +160,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do then pure (Search.TeamOnly t) else do -- For team users, we need to check the visibility flag - handleTeamVisibility t <$> liftSem (GalleyProvider.getTeamSearchVisibility t) + handleTeamVisibility t <$> liftSem (GalleyAPIAccess.getTeamSearchVisibility t) exactHandleSearch :: (Handler r) (Maybe Contact) exactHandleSearch = do @@ -168,7 +172,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do <$$> HandleAPI.getLocalHandleInfo lsearcherId handle teamUserSearch :: - Member GalleyProvider r => + Member GalleyAPIAccess r => UserId -> TeamId -> Maybe Text -> diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index d329843c74f..481a8b8cafa 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -48,8 +48,6 @@ import Brig.Data.User qualified as Data import Brig.Data.UserKey import Brig.Data.UserKey qualified as Data import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Brig.Email import Brig.Options qualified as Opt import Brig.Phone @@ -85,6 +83,8 @@ import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.Sso +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (InternalPaging) @@ -130,7 +130,7 @@ lookupLoginCode phone = login :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -174,7 +174,7 @@ login (SmsLogin (SmsLoginData phone code label)) typ = do verifyCode :: forall r. - Member GalleyProvider r => + Member GalleyAPIAccess r => Maybe Code.Value -> VerificationAction -> UserId -> @@ -182,7 +182,7 @@ verifyCode :: verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do - mbFeatureEnabled <- liftSem $ GalleyProvider.getVerificationCodeEnabled `traverse` mbTeamId + mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe (Public.wsStatus (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid when (featureEnabled && not isSsoUser) $ do @@ -448,7 +448,7 @@ ssoLogin (SsoLogin uid label) typ = do -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. legalHoldLogin :: - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member TinyLog r, @@ -464,7 +464,7 @@ legalHoldLogin (LegalHoldLogin uid pw label) typ = do -- legalhold login is only possible if -- the user is a team user -- and the team has legalhold enabled - mteam <- lift $ liftSem $ GalleyProvider.getTeamId uid + mteam <- lift $ liftSem $ GalleyAPIAccess.getTeamId uid case mteam of Nothing -> throwE LegalHoldLoginNoBindingTeam Just tid -> assertLegalHoldEnabled tid @@ -473,11 +473,11 @@ legalHoldLogin (LegalHoldLogin uid pw label) typ = do !>> LegalHoldLoginError assertLegalHoldEnabled :: - Member GalleyProvider r => + Member GalleyAPIAccess r => TeamId -> ExceptT LegalHoldLoginError (AppT r) () assertLegalHoldEnabled tid = do - stat <- lift $ liftSem $ GalleyProvider.getTeamLegalHoldStatus tid + stat <- lift $ liftSem $ GalleyAPIAccess.getTeamLegalHoldStatus tid case wsStatus stat of FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled FeatureStatusEnabled -> pure () diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index b5afec1f8f0..e04538621c0 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -27,8 +27,6 @@ import Brig.API.User (lookupHandle) import Brig.App import Brig.Data.Connection qualified as Conn import Brig.Data.User (lookupUser) -import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider qualified as GalleyProvider import Control.Error hiding (bool) import Control.Lens (view, (^.)) import Data.Aeson qualified as A @@ -46,12 +44,14 @@ import Wire.API.Push.Token qualified as PushTok import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (EJPDRequestBody), EJPDResponseBody (EJPDResponseBody), EJPDResponseItem (EJPDResponseItem)) import Wire.API.Team.Member qualified as Team import Wire.API.User +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.Rpc ejpdRequest :: forall r. - ( Member GalleyProvider r, + ( Member GalleyAPIAccess r, Member NotificationSubsystem r, Member Rpc r ) => @@ -94,7 +94,7 @@ ejpdRequest (fromMaybe False -> includeContacts) (EJPDRequestBody handles) = do mbTeamContacts <- case (reallyIncludeContacts, userTeam target) of (True, Just tid) -> do - memberList <- liftSem $ GalleyProvider.getTeamMembers tid + memberList <- liftSem $ GalleyAPIAccess.getTeamMembers tid let members = (view Team.userId <$> (memberList ^. Team.teamMembers)) \\ [uid] contactsFull :: [Maybe EJPDResponseItem] <- diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 66254e93fa1..1ea564fcbb5 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -861,17 +861,16 @@ testCreateUserAnonExpiry :: Brig -> Http () testCreateUserAnonExpiry b = do u1 <- randomUser b alice <- randomUser b - now <- liftIO getCurrentTime bob <- createAnonUserExpiry (Just 2) "bob" b liftIO $ assertBool "expiry not set on regular creation" (isNothing (userExpire alice)) - ensureExpiry now (fromUTCTimeMillis <$> userExpire bob) "bob/register" + ensureExpiry (fromUTCTimeMillis <$> userExpire bob) "bob/register" resAlice <- getProfile (userId u1) (userId alice) resBob <- getProfile (userId u1) (userId bob) selfBob <- get (b . zUser (userId bob) . path "self") 0) $ do liftIO $ threadDelay 1000000 awaitExpiry (n - 1) zusr uid - ensureExpiry :: UTCTime -> Maybe UTCTime -> String -> Http () - ensureExpiry now expiry s = case expiry of - Nothing -> liftIO $ assertFailure ("user must have an expiry" <> s) - Just a -> do - let diff = diffUTCTime a now - minExp = 1 :: Integer -- 1 second - maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days - liftIO $ assertBool "expiry must in be the future" (diff >= fromIntegral minExp) - liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) + ensureExpiry :: Maybe UTCTime -> String -> Http () + ensureExpiry expiry s = do + now <- liftIO getCurrentTime + case expiry of + Nothing -> liftIO $ assertFailure ("user must have an expiry" <> s) + Just a -> do + let diff = diffUTCTime a now + minExp = 1 :: Integer -- 1 second + maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days + liftIO $ assertBool "expiry must in be the future" (diff >= fromIntegral minExp) + liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) expire :: ResponseLBS -> Maybe UTCTime expire r = field "expires_at" =<< responseJsonMaybe r deleted :: ResponseLBS -> Maybe Bool diff --git a/services/brig/test/unit/Test/Brig/InternalNotification.hs b/services/brig/test/unit/Test/Brig/InternalNotification.hs index 696863fe707..fed7ff008f1 100644 --- a/services/brig/test/unit/Test/Brig/InternalNotification.hs +++ b/services/brig/test/unit/Test/Brig/InternalNotification.hs @@ -17,13 +17,13 @@ module Test.Brig.InternalNotification where -import Brig.InternalEvent.Types (InternalNotification (..)) import Data.Aeson qualified as A import Data.ByteString.Lazy as BSL import Data.Id (clientToText) import Imports import Test.Tasty import Test.Tasty.HUnit +import Wire.InternalEvent (InternalNotification (..)) tests :: TestTree tests = diff --git a/services/spar/test/Test/Spar/Sem/NowSpec.hs b/services/spar/test/Test/Spar/Sem/NowSpec.hs index 91cf3acdcd7..57de87070d4 100644 --- a/services/spar/test/Test/Spar/Sem/NowSpec.hs +++ b/services/spar/test/Test/Spar/Sem/NowSpec.hs @@ -27,7 +27,6 @@ import Data.Time.Calendar.Julian import Imports import Polysemy import Polysemy.Input -import SAML2.WebSSO.Types import Test.Hspec import Test.Hspec.QuickCheck import Wire.Sem.Now.IO @@ -41,4 +40,4 @@ spec :: Spec spec = do modifyMaxSuccess (const 1000) $ do propsForInterpreter "nowToIO" $ fmap Identity . runM . nowToIO . runInputConst () - propsForInterpreter "nowToInput" $ pure . Identity . run . runInputConst someTime . nowToInput @Time . runInputConst () + propsForInterpreter "nowToInput" $ pure . Identity . run . runInputConst someTime . nowToInput . runInputConst () diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs index ebb65c85e3c..acfa6afa731 100644 --- a/tools/stern/test/integration/Util.hs +++ b/tools/stern/test/integration/Util.hs @@ -240,5 +240,7 @@ getTeamMember getter tid gettee = do getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> UserId -> TeamId -> UserId -> m TeamMember getTeamMember' g getter tid gettee = do - r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter) Date: Thu, 2 May 2024 17:31:41 +0200 Subject: [PATCH 09/30] Servantify stern (#4030) * Remove outdated comment in galley. * Remove unnecessary wai-routing dependency from stern. * update default.nix * hi ci --- services/galley/src/Galley/Run.hs | 1 - tools/stern/default.nix | 2 -- tools/stern/src/Stern/App.hs | 5 +++-- tools/stern/stern.cabal | 1 - 4 files changed, 3 insertions(+), 6 deletions(-) diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index c54804f6c39..bda488ad4b6 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -131,7 +131,6 @@ mkApp opts = Aeson.encode $ mkError HTTP.status404 "no-endpoint" "The requested endpoint does not exist" - -- the servant API wraps the one defined using wai-routing servantApp :: Env -> Application servantApp e0 r cont = do rid <- lookupReqId (e0 ^. applog) r diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 4461863a63d..5c9adf4ce7d 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -49,7 +49,6 @@ , utf8-string , uuid , wai -, wai-routing , wai-utilities , wire-api , yaml @@ -92,7 +91,6 @@ mkDerivation { utf8-string uuid wai - wai-routing wai-utilities wire-api yaml diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index e5b74b1b11d..0f3b0aa5e4b 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -39,8 +39,7 @@ import Data.UUID (toString) import Data.UUID.V4 qualified as UUID import Imports import Network.HTTP.Client (responseTimeoutMicro) -import Network.Wai (Request, ResponseReceived) -import Network.Wai.Routing (Continue) +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) @@ -125,6 +124,8 @@ runAppT e (AppT ma) = runReaderT ma e 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 r) diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 9a31ed65918..9d3634cccc2 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -104,7 +104,6 @@ library , utf8-string , uuid >=1.3 , wai >=3.0 - , wai-routing >=0.10 , wai-utilities >=0.9 , wire-api >=0.1 , yaml From ee762a0b0ba7fc35763b81d6a167c0d643aab4e0 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 2 May 2024 18:37:39 +0200 Subject: [PATCH 10/30] WPB-8988 Upgrade `rusty-jwt-tools` to support `ecdsa_secp256r1_sha256` (#4035) --- changelog.d/2-features/WPB-8988 | 1 + hack/helm_vars/wire-server/values.yaml.gotmpl | 7 ++-- libs/jwt-tools/default.nix | 9 +---- libs/jwt-tools/jwt-tools.cabal | 4 +-- libs/jwt-tools/test/Spec.hs | 36 ------------------- nix/pkgs/rusty_jwt_tools_ffi/default.nix | 11 +++--- services/brig/brig.integration.yaml | 2 +- .../brig/test/integration/API/User/Client.hs | 26 ++++++++++++-- .../jwt/ecdsa_secp256r1_sha256_key.pem | 5 +++ .../{ed25519_bundle.pem => ed25519_key.pem} | 3 -- 10 files changed, 42 insertions(+), 62 deletions(-) create mode 100644 changelog.d/2-features/WPB-8988 create mode 100644 services/brig/test/resources/jwt/ecdsa_secp256r1_sha256_key.pem rename services/brig/test/resources/jwt/{ed25519_bundle.pem => ed25519_key.pem} (51%) diff --git a/changelog.d/2-features/WPB-8988 b/changelog.d/2-features/WPB-8988 new file mode 100644 index 00000000000..fa19b506056 --- /dev/null +++ b/changelog.d/2-features/WPB-8988 @@ -0,0 +1 @@ +Upgrade `rusty-jwt-tools` to support `ecdsa_secp256r1_sha256` diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index 614b83441be..11cf79753cd 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -151,11 +151,10 @@ brig: smtpPassword: dummy-smtp-password dpopSigKeyBundle: | -----BEGIN PRIVATE KEY----- - MC4CAQAwBQYDK2VwBCIEIFANnxZLNE4p+GDzWzR3wm/v8x/0bxZYkCyke1aTRucX + MIGHAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBG0wawIBAQQgokD9kGYErMooLqpv + IRUVCtV1l6HmtqTJUFun0/4XLuahRANCAASWH/qkgOLwZz1GvEt0ch4HPRQUoj9U + TL8L7QANF9JztsEQ2omrX9l7RoosjAm+PKwrL+c3GiT63CSd1qrUpoZa -----END PRIVATE KEY----- - -----BEGIN PUBLIC KEY----- - MCowBQYDK2VwAyEACPvhIdimF20tOPjbb+fXJrwS2RKDp7686T90AZ0+Th8= - -----END PUBLIC KEY----- oauthJwkKeyPair: | { "kty": "OKP", diff --git a/libs/jwt-tools/default.nix b/libs/jwt-tools/default.nix index 1314bde5186..26a5f5f455d 100644 --- a/libs/jwt-tools/default.nix +++ b/libs/jwt-tools/default.nix @@ -4,7 +4,6 @@ # dependencies are added or removed. { mkDerivation , base -, bytestring , bytestring-conversion , gitignoreSource , hspec @@ -29,13 +28,7 @@ mkDerivation { utf8-string ]; librarySystemDepends = [ rusty_jwt_tools_ffi ]; - testHaskellDepends = [ - bytestring - hspec - imports - string-conversions - transformers - ]; + testHaskellDepends = [ hspec imports string-conversions ]; description = "FFI to rusty-jwt-tools"; license = lib.licenses.agpl3Only; } diff --git a/libs/jwt-tools/jwt-tools.cabal b/libs/jwt-tools/jwt-tools.cabal index e2f12a9b352..4cc7800ef9d 100644 --- a/libs/jwt-tools/jwt-tools.cabal +++ b/libs/jwt-tools/jwt-tools.cabal @@ -80,12 +80,10 @@ test-suite jwt-tools-tests main-is: Spec.hs type: exitcode-stdio-1.0 build-depends: - bytestring - , hspec + hspec , imports , jwt-tools , string-conversions - , transformers hs-source-dirs: test default-language: GHC2021 diff --git a/libs/jwt-tools/test/Spec.hs b/libs/jwt-tools/test/Spec.hs index 664c18d3874..03c9e53ba79 100644 --- a/libs/jwt-tools/test/Spec.hs +++ b/libs/jwt-tools/test/Spec.hs @@ -15,8 +15,6 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -import Control.Monad.Trans.Except -import Data.ByteString.Char8 (split) import Data.Jwt.Tools import Data.String.Conversions import Imports @@ -24,18 +22,6 @@ import Test.Hspec main :: IO () main = hspec $ do - describe "generateDpopToken FFI when passing valid inputs" $ do - it "should return an access token with the correct header" $ do - actual <- runExceptT $ generateDpopToken proof uid cid handle displayName tid domain nonce uri method maxSkewSecs expires now pem - -- The actual payload of the DPoP token is not deterministic as it depends on the current time. - -- We therefore only check the header, because if the header is correct, it means the token creation was successful.s - let expectedHeader = "eyJhbGciOiJFZERTQSIsInR5cCI6ImF0K2p3dCIsImp3ayI6eyJrdHkiOiJPS1AiLCJjcnYiOiJFZDI1NTE5IiwieCI6ImRZSTM4VWR4a3NDMEs0UXg2RTlKSzlZZkdtLWVoblkxOG9LbUhMMllzWmsifX0" - let actualHeader = either (const "") (head . split '.') actual - actualHeader `shouldBe` expectedHeader - describe "generateDpopToken FFI when passing a wrong nonce value" $ do - it "should return BackendNonceMismatchError" $ do - actual <- runExceptT $ generateDpopToken proof uid cid handle displayName tid domain (Nonce "foobar") uri method maxSkewSecs expires now pem - actual `shouldBe` Left BackendNonceMismatchError describe "toResult" $ do it "should convert to correct error" $ do toResult Nothing (Just token) `shouldBe` Right (cs token) @@ -103,25 +89,3 @@ main = hspec $ do toResult Nothing Nothing `shouldBe` Left UnknownError where token = "" - proof = Proof "eyJhbGciOiJFZERTQSIsImp3ayI6eyJjcnYiOiJFZDI1NTE5Iiwia3R5IjoiT0tQIiwieCI6Im5MSkdOLU9hNkpzcTNLY2xaZ2dMbDdVdkFWZG1CMFE2QzNONUJDZ3BoSHcifSwidHlwIjoiZHBvcCtqd3QifQ.eyJhdWQiOiJodHRwczovL3dpcmUuY29tL2FjbWUvY2hhbGxlbmdlL2FiY2QiLCJjaGFsIjoid2EyVnJrQ3RXMXNhdUoyRDN1S1k4cmM3eTRrbDR1c0giLCJleHAiOjE3Mzk4ODA2NzQsImhhbmRsZSI6IndpcmVhcHA6Ly8lNDB5d2Z5ZG5pZ2Jud2h1b3pldGphZ3FAZXhhbXBsZS5jb20iLCJodG0iOiJQT1NUIiwiaHR1IjoiaHR0cHM6Ly9leGFtcGxlLmNvbS9jbGllbnRzL2NjNmU2NDBlMjk2ZThiYmEvYWNjZXNzLXRva2VuIiwiaWF0IjoxNzA4MzQ0Njc0LCJqdGkiOiI2ZmM1OWU3Zi1iNjY2LTRmZmMtYjczOC00ZjQ3NjBjODg0Y2EiLCJuYW1lIjoi5reB4qqu5KSq5rK255Kh4bKV6re14Y2q6omE6Jy16Iu17ICV54Kb66-v56qp5KqW766M6bGw6oOy6b6m57m15pWJ4LqH54et6rOj54KHIiwibmJmIjoxNzA4MzQ0Njc0LCJub25jZSI6IllWZ2dHdWlTUTZlamhQNTNFX0tPS3ciLCJzdWIiOiJ3aXJlYXBwOi8vSWZ0VzBLeFVSb2F1QWVockRremJiQSFjYzZlNjQwZTI5NmU4YmJhQGV4YW1wbGUuY29tIiwidGVhbSI6ImMxNTE5NzVlLWIxOTMtNDAwOS1hM2QyLTc0N2M5NjFmMjMzMyJ9.SHxpMzOe2yC3y6DP7lEH0l7_eOKrUZZI0OjgtnCKjO4OBD0XqKOi0y_z07-7FWc-KtThlsaZatnBNTB67GhQBw" - uid = UserId "21fb56d0-ac54-4686-ae01-e86b0e4cdb6c" - nonce = Nonce "YVggGuiSQ6ejhP53E_KOKw" - expires = ExpiryEpoch 1739967074 - handle = Handle "ywfydnigbnwhuozetjagq" - displayName = DisplayName "\230\183\129\226\170\174\228\164\170\230\178\182\231\146\161\225\178\149\234\183\181\225\141\170\234\137\132\232\156\181\232\139\181\236\128\149\231\130\155\235\175\175\231\170\169\228\170\150\239\174\140\233\177\176\234\131\178\233\190\166\231\185\181\230\149\137\224\186\135\231\135\173\234\179\163\231\130\135" - tid = TeamId "c151975e-b193-4009-a3d2-747c961f2333" - - now = NowEpoch 1704982162 - cid = ClientId 14730821443162901434 - domain = Domain "example.com" - uri = Uri "https://example.com/clients/cc6e640e296e8bba/access-token" - method = POST - maxSkewSecs = MaxSkewSecs 1 - pem = - PemBundle $ - "-----BEGIN PRIVATE KEY-----\n\ - \MC4CAQAwBQYDK2VwBCIEIMkvahkqR9sHJSmFeCl3B7aJjsQGgwy++cccWTbuDyy+\n\ - \-----END PRIVATE KEY-----\n\ - \-----BEGIN PUBLIC KEY-----\n\ - \MCowBQYDK2VwAyEAdYI38UdxksC0K4Qx6E9JK9YfGm+ehnY18oKmHL2YsZk=\n\ - \-----END PUBLIC KEY-----\n" diff --git a/nix/pkgs/rusty_jwt_tools_ffi/default.nix b/nix/pkgs/rusty_jwt_tools_ffi/default.nix index 32e735bc849..adb3ef3b800 100644 --- a/nix/pkgs/rusty_jwt_tools_ffi/default.nix +++ b/nix/pkgs/rusty_jwt_tools_ffi/default.nix @@ -14,8 +14,8 @@ let src = fetchFromGitHub { owner = "wireapp"; repo = "rusty-jwt-tools"; - rev = "60424bf7031e2fa535aac658d0b5643624d19537"; - sha256 = "sha256-kdubK9FruZT8pbIwCHyAkxYj9yVM0q7ivNhNUNtNQCY="; + rev = "05441e98d9c7c5ec9bfcfba84e885988278f10e6"; + sha256 = "sha256-HVq2BpPKp3cfdlKrS1AYWQ+a5VigFsYfSecZ60SFATI="; }; cargoLockFile = builtins.toFile "cargo.lock" (builtins.readFile "${src}/Cargo.lock"); @@ -29,8 +29,11 @@ rustPlatform.buildRustPackage { outputHashes = { # if any of these need updating, replace / create new key with # lib.fakeSha256, rebuild, and replace with actual hash. - "certval-0.1.4" = "sha256-gzkRC7/u/rARGPy3d37eBrAVml4XSDb6bRPpsESmttY="; - "jwt-simple-0.12.1" = "sha256-5PAOwulL8j6f4Ycoa5Q+1dqEA24uN8rJt+i2RebL6eo="; + "certval-0.1.4" = "sha256-4BWvSzFZhlA+mKj+Y6GNEwNSKikNGVjDoPxyxiw9TFE="; + "biscuit-0.6.0-beta1" = "sha256-no7b4Un+7AES7EwWdZh/oeIa4w0caKLAUFsHWqgJOrg="; + "jwt-simple-0.13.0" = "sha256-QkVi7EGrU3nF+/32tNjTtAILo8sjasR27nyRgBH+xoA="; + "rcgen-0.9.2" = "sha256-3jFzInwdzFBot+L2Vm5NLF1ml33GH2+Iv3LqqGhLxFs="; + "ring-0.17.0-not-released-yet" = "sha256-TP8yZo64J/d1fw8l2J4+ol70EcHvpvHJBdpF3A+6Dgo="; }; }; diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 38f0208b31c..1723ec9f1e5 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -209,7 +209,7 @@ optSettings: setNonceTtlSecs: 5 setDpopMaxSkewSecs: 1 setDpopTokenExpirationTimeSecs: 300 # 5 minutes - setPublicKeyBundle: test/resources/jwt/ed25519_bundle.pem + setPublicKeyBundle: test/resources/jwt/ecdsa_secp256r1_sha256_key.pem setEnableMLS: true # To only allow specific email address domains to register, uncomment and update the setting below # setAllowlistEmailDomains: diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index df4b7c5faaa..0fb44b9063f 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -1472,7 +1472,7 @@ testCreateAccessToken opts n brig = do handle (fromName u.userDisplayName) (UUID.toText (toUUID tid)) - signedOrError <- fmap encodeCompact <$> liftIO (signAccessToken dpopClaims) + signedOrError <- fmap encodeCompact <$> liftIO (signProofEcdsaP256 dpopClaims) case signedOrError of Left err -> liftIO $ assertFailure $ "failed to sign claims: " <> show err Right signed -> do @@ -1483,8 +1483,9 @@ testCreateAccessToken opts n brig = do let accessToken = fromRight (error $ "failed to create token: " <> show response) $ responseJsonEither response liftIO $ datrType accessToken @?= DPoP where - signAccessToken :: DPoPClaimsSet -> IO (Either JWTError SignedJWT) - signAccessToken claims = runJOSE $ do + -- FUTUREWORK: parameterize the signing algorithm + _signProof :: DPoPClaimsSet -> IO (Either JWTError SignedJWT) + _signProof claims = runJOSE $ do algo <- bestJWSAlg jwkKey let h = newJWSHeader ((), algo) @@ -1492,6 +1493,15 @@ testCreateAccessToken opts n brig = do & (typ ?~ HeaderParam () "dpop+jwt") signJWT jwkKey h claims + signProofEcdsaP256 :: DPoPClaimsSet -> IO (Either JWTError SignedJWT) + signProofEcdsaP256 claims = runJOSE $ do + algo <- bestJWSAlg jwkKeyBundleEcdsaP256 + let h = + newJWSHeader ((), algo) + & (jwk ?~ HeaderParam () jwkPublicKeyEcdsaP256) + & (typ ?~ HeaderParam () "dpop+jwt") + signJWT jwkKeyBundleEcdsaP256 h claims + jwkKey :: JWK jwkKey = do fromMaybe (error "invalid jwk") . A.decode $ @@ -1502,6 +1512,16 @@ testCreateAccessToken opts n brig = do fromMaybe (error "invalid jwk") . A.decode $ "{\"kty\":\"OKP\",\"crv\":\"Ed25519\",\"x\":\"nLJGN-Oa6Jsq3KclZggLl7UvAVdmB0Q6C3N5BCgphHw\"}" + jwkKeyBundleEcdsaP256 :: JWK + jwkKeyBundleEcdsaP256 = do + fromMaybe (error "invalid jwk") . A.decode $ + "{\"kty\":\"EC\",\"alg\":\"ES256\",\"crv\":\"P-256\",\"x\":\"hcYjloNodyCLF_rQd_HIszSpa2J-vzrgntneAJW5pA8\",\"y\":\"6MXxnHq1FmAWCc6A7YValxvekicBv53ARTQO35mRKJ8\",\"d\":\"yz1weEXJbJao6wLiml8fahLt3BnJxdHWfbpUB0i8GLo\"}" + + jwkPublicKeyEcdsaP256 :: JWK + jwkPublicKeyEcdsaP256 = do + fromMaybe (error "invalid jwk") . A.decode $ + "{\"kty\":\"EC\",\"alg\":\"ES256\",\"crv\":\"P-256\",\"x\":\"hcYjloNodyCLF_rQd_HIszSpa2J-vzrgntneAJW5pA8\",\"y\":\"6MXxnHq1FmAWCc6A7YValxvekicBv53ARTQO35mRKJ8\"}" + testCreateAccessTokenMissingProof :: Brig -> Http () testCreateAccessTokenMissingProof brig = do uid <- userId <$> randomUser brig diff --git a/services/brig/test/resources/jwt/ecdsa_secp256r1_sha256_key.pem b/services/brig/test/resources/jwt/ecdsa_secp256r1_sha256_key.pem new file mode 100644 index 00000000000..290e7d7019e --- /dev/null +++ b/services/brig/test/resources/jwt/ecdsa_secp256r1_sha256_key.pem @@ -0,0 +1,5 @@ +-----BEGIN PRIVATE KEY----- +MIGHAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBG0wawIBAQQgokD9kGYErMooLqpv +IRUVCtV1l6HmtqTJUFun0/4XLuahRANCAASWH/qkgOLwZz1GvEt0ch4HPRQUoj9U +TL8L7QANF9JztsEQ2omrX9l7RoosjAm+PKwrL+c3GiT63CSd1qrUpoZa +-----END PRIVATE KEY----- diff --git a/services/brig/test/resources/jwt/ed25519_bundle.pem b/services/brig/test/resources/jwt/ed25519_key.pem similarity index 51% rename from services/brig/test/resources/jwt/ed25519_bundle.pem rename to services/brig/test/resources/jwt/ed25519_key.pem index afbd4dfb0ec..a9d04d69b8c 100644 --- a/services/brig/test/resources/jwt/ed25519_bundle.pem +++ b/services/brig/test/resources/jwt/ed25519_key.pem @@ -1,6 +1,3 @@ -----BEGIN PRIVATE KEY----- MC4CAQAwBQYDK2VwBCIEIFANnxZLNE4p+GDzWzR3wm/v8x/0bxZYkCyke1aTRucX -----END PRIVATE KEY----- ------BEGIN PUBLIC KEY----- -MCowBQYDK2VwAyEACPvhIdimF20tOPjbb+fXJrwS2RKDp7686T90AZ0+Th8= ------END PUBLIC KEY----- From 69411dae20f1ab80753d73bea2f4c206a2eaee2c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 3 May 2024 15:26:13 +0200 Subject: [PATCH 11/30] WPB-8702 Retrieve in database users that can only login with Phone Numbers & SMS to login (#4024) --- cabal.project | 5 +- changelog.d/5-internal/WPB-8702 | 1 + nix/local-haskell-packages.nix | 1 + tools/db/phone-users/.ormolu | 1 + tools/db/phone-users/README.md | 44 +++++ tools/db/phone-users/app/Main.hs | 23 +++ tools/db/phone-users/default.nix | 48 +++++ tools/db/phone-users/phone-users.cabal | 96 ++++++++++ tools/db/phone-users/src/PhoneUsers/Lib.hs | 177 ++++++++++++++++++ tools/db/phone-users/src/PhoneUsers/Types.hs | 184 +++++++++++++++++++ 10 files changed, 579 insertions(+), 1 deletion(-) create mode 100644 changelog.d/5-internal/WPB-8702 create mode 120000 tools/db/phone-users/.ormolu create mode 100644 tools/db/phone-users/README.md create mode 100644 tools/db/phone-users/app/Main.hs create mode 100644 tools/db/phone-users/default.nix create mode 100644 tools/db/phone-users/phone-users.cabal create mode 100644 tools/db/phone-users/src/PhoneUsers/Lib.hs create mode 100644 tools/db/phone-users/src/PhoneUsers/Types.hs diff --git a/cabal.project b/cabal.project index 932f0f55399..5ebc608c29e 100644 --- a/cabal.project +++ b/cabal.project @@ -48,6 +48,7 @@ packages: , tools/db/inconsistencies/ , tools/db/migrate-sso-feature-flag/ , tools/db/move-team/ + , tools/db/phone-users/ , tools/db/repair-handles/ , tools/db/repair-brig-clients-table/ , tools/db/service-backfill/ @@ -127,6 +128,8 @@ package proxy ghc-options: -Werror package mlsstats ghc-options: -Werror +package phone-users + ghc-options: -Werror package rabbitmq-consumer ghc-options: -Werror package repair-handles @@ -179,6 +182,6 @@ package fedcalls -- - these packages have bounds that are justified with their current -- dependency set, however, we have updated their dependencies, such -- that they work with newer base and ghc (api) versions -allow-newer: +allow-newer: , proto-lens-protoc:base , proto-lens-protoc:ghc diff --git a/changelog.d/5-internal/WPB-8702 b/changelog.d/5-internal/WPB-8702 new file mode 100644 index 00000000000..442ee8a831a --- /dev/null +++ b/changelog.d/5-internal/WPB-8702 @@ -0,0 +1 @@ +Add tool to determine number of phone-only users diff --git a/nix/local-haskell-packages.nix b/nix/local-haskell-packages.nix index 289d38bdd7c..89527deeb19 100644 --- a/nix/local-haskell-packages.nix +++ b/nix/local-haskell-packages.nix @@ -49,6 +49,7 @@ inconsistencies = hself.callPackage ../tools/db/inconsistencies/default.nix { inherit gitignoreSource; }; migrate-sso-feature-flag = hself.callPackage ../tools/db/migrate-sso-feature-flag/default.nix { inherit gitignoreSource; }; move-team = hself.callPackage ../tools/db/move-team/default.nix { inherit gitignoreSource; }; + phone-users = hself.callPackage ../tools/db/phone-users/default.nix { inherit gitignoreSource; }; repair-brig-clients-table = hself.callPackage ../tools/db/repair-brig-clients-table/default.nix { inherit gitignoreSource; }; repair-handles = hself.callPackage ../tools/db/repair-handles/default.nix { inherit gitignoreSource; }; service-backfill = hself.callPackage ../tools/db/service-backfill/default.nix { inherit gitignoreSource; }; diff --git a/tools/db/phone-users/.ormolu b/tools/db/phone-users/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/phone-users/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/phone-users/README.md b/tools/db/phone-users/README.md new file mode 100644 index 00000000000..ab03b0b8fa1 --- /dev/null +++ b/tools/db/phone-users/README.md @@ -0,0 +1,44 @@ +# Phone users + +This program scans brig's users table and determines the number of users that can only login by phone/sms. + +Example usage: + +```shell +phone-users --brig-cassandra-keyspace brig --galley-cassandra-keyspace galley -l 100000 +``` + +Display usage: + +```shell +phone-users -h +``` + +```text +phone-users + +Usage: phone-users [--brig-cassandra-host HOST] [--brig-cassandra-port PORT] + [--brig-cassandra-keyspace STRING] + [--galley-cassandra-host HOST] [--galley-cassandra-port PORT] + [--galley-cassandra-keyspace STRING] [-l|--limit INT] + + This program scans brig's users table and determines the number of users that + can only login by phone/sms + +Available options: + -h,--help Show this help text + --brig-cassandra-host HOST + Cassandra Host for brig (default: "localhost") + --brig-cassandra-port PORT + Cassandra Port for brig (default: 9042) + --brig-cassandra-keyspace STRING + Cassandra Keyspace for brig (default: "brig_test") + --galley-cassandra-host HOST + Cassandra Host for galley (default: "localhost") + --galley-cassandra-port PORT + Cassandra Port for galley (default: 9043) + --galley-cassandra-keyspace STRING + Cassandra Keyspace for galley + (default: "galley_test") + -l,--limit INT Limit the number of users to process +``` diff --git a/tools/db/phone-users/app/Main.hs b/tools/db/phone-users/app/Main.hs new file mode 100644 index 00000000000..be8658b8005 --- /dev/null +++ b/tools/db/phone-users/app/Main.hs @@ -0,0 +1,23 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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 Main where + +import qualified PhoneUsers.Lib as Lib + +main :: IO () +main = Lib.main diff --git a/tools/db/phone-users/default.nix b/tools/db/phone-users/default.nix new file mode 100644 index 00000000000..2903ef57701 --- /dev/null +++ b/tools/db/phone-users/default.nix @@ -0,0 +1,48 @@ +# WARNING: GENERATED FILE, DO NOT EDIT. +# This file is generated by running hack/bin/generate-local-nix-packages.sh and +# must be regenerated whenever local packages are added or removed, or +# dependencies are added or removed. +{ mkDerivation +, aeson +, aeson-pretty +, base +, bytestring +, cassandra-util +, conduit +, cql +, gitignoreSource +, imports +, lens +, lib +, optparse-applicative +, time +, tinylog +, types-common +, wire-api +}: +mkDerivation { + pname = "phone-users"; + version = "1.0.0"; + src = gitignoreSource ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson + aeson-pretty + bytestring + cassandra-util + conduit + cql + imports + lens + optparse-applicative + time + tinylog + types-common + wire-api + ]; + executableHaskellDepends = [ base ]; + description = "Check users that are only able to login via phone"; + license = lib.licenses.agpl3Only; + mainProgram = "phone-users"; +} diff --git a/tools/db/phone-users/phone-users.cabal b/tools/db/phone-users/phone-users.cabal new file mode 100644 index 00000000000..ab9c01f8284 --- /dev/null +++ b/tools/db/phone-users/phone-users.cabal @@ -0,0 +1,96 @@ +cabal-version: 3.0 +name: phone-users +version: 1.0.0 +synopsis: Check users that are only able to login via phone +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2024 Wire Swiss GmbH +license: AGPL-3.0-only +build-type: Simple + +library + hs-source-dirs: src + exposed-modules: + PhoneUsers.Lib + PhoneUsers.Types + + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -funbox-strict-fields -threaded -with-rtsopts=-N + -Wredundant-constraints -Wunused-packages + + build-depends: + , aeson + , aeson-pretty + , bytestring + , cassandra-util + , conduit + , cql + , imports + , lens + , optparse-applicative + , time + , tinylog + , types-common + , wire-api + + default-extensions: + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + +executable phone-users + main-is: Main.hs + build-depends: + , base + , phone-users + + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -funbox-strict-fields -threaded -with-rtsopts=-N + -Wredundant-constraints -Wunused-packages diff --git a/tools/db/phone-users/src/PhoneUsers/Lib.hs b/tools/db/phone-users/src/PhoneUsers/Lib.hs new file mode 100644 index 00000000000..8c913b7a0bf --- /dev/null +++ b/tools/db/phone-users/src/PhoneUsers/Lib.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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 PhoneUsers.Lib where + +import Cassandra as C +import Cassandra.Settings as C +import Data.Conduit +import qualified Data.Conduit.Combinators as Conduit +import qualified Data.Conduit.List as CL +import Data.Id (TeamId, UserId) +import Data.Time +import qualified Database.CQL.Protocol as CQL +import Imports +import Options.Applicative +import PhoneUsers.Types +-- import qualified System.IO as SIO +import qualified System.Logger as Log +import System.Logger.Message ((.=), (~~)) +import Wire.API.Team.Feature (FeatureStatus (FeatureStatusDisabled, FeatureStatusEnabled)) +import Wire.API.User (AccountStatus (Active)) + +lookupClientsLastActiveTimestamps :: ClientState -> UserId -> IO [Maybe UTCTime] +lookupClientsLastActiveTimestamps client u = do + runClient client $ runIdentity <$$> retry x1 (query selectClients (params One (Identity u))) + where + selectClients :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime)) + selectClients = "SELECT last_active from clients where user = ?" + +readUsers :: ClientState -> ConduitM () [UserRow] IO () +readUsers client = + transPipe (runClient client) (paginateC selectUsersAll (paramsP One () 1000) x5) + .| Conduit.map (fmap CQL.asRecord) + where + selectUsersAll :: C.PrepQuery C.R () (CQL.TupleType UserRow) + selectUsersAll = + "SELECT id, email, phone, activated, status, team FROM user" + +getConferenceCalling :: ClientState -> TeamId -> IO (Maybe FeatureStatus) +getConferenceCalling client tid = do + runClient client $ runIdentity <$$> retry x1 (query1 select (params One (Identity tid))) + where + select :: PrepQuery R (Identity TeamId) (Identity FeatureStatus) + select = + "select conference_calling from team_features where team_id = ?" + +process :: Log.Logger -> Maybe Int -> ClientState -> ClientState -> IO Result +process logger limit brigClient galleyClient = + runConduit $ + readUsers brigClient + -- .| Conduit.mapM (\chunk -> SIO.hPutStr stderr "." $> chunk) + .| Conduit.concat + .| (maybe (Conduit.filter (const True)) Conduit.take limit) + .| Conduit.mapM (getUserInfo logger brigClient galleyClient) + .| forever (CL.isolate 10000 .| (Conduit.foldMap infoToResult >>= yield)) + .| Conduit.takeWhile ((> 0) . usersSearched) + .| CL.scan (<>) mempty + `fuseUpstream` Conduit.mapM_ (\r -> Log.info logger $ "intermediate_result" .= show r) + +getUserInfo :: Log.Logger -> ClientState -> ClientState -> UserRow -> IO UserInfo +getUserInfo logger brigClient galleyClient ur = do + if not $ isCandidate + then pure NoPhoneUser + else do + -- should we give C* a little break here and add a small threadDelay? + -- threadDelay 200 + lastActiveTimeStamps <- lookupClientsLastActiveTimestamps brigClient ur.id + now <- getCurrentTime + -- activity: + -- inactive: they have no client or client's last_active is greater than 90 days ago + -- active: otherwise + -- last_active is null on client creation, but it will be set once notifications are fetched + -- therefore we can consider empty last_active as inactive + let activeLast90Days = any (clientWasActiveLast90Days now) $ catMaybes lastActiveTimeStamps + userInfo <- + if activeLast90Days + then do + apu <- case ur.team of + Nothing -> pure ActivePersonalUser + Just tid -> do + isPaying <- isPayingTeam galleyClient tid + pure $ + if isPaying + then ActiveTeamUser Free + else ActiveTeamUser Paid + Log.info logger $ + "active_phone_user" .= show apu + ~~ "user_record" .= show ur + ~~ "last_active_timestamps" .= show lastActiveTimeStamps + ~~ Log.msg (Log.val "active phone user found") + pure apu + else pure InactiveLast90Days + pure $ PhoneUser userInfo + where + -- to qualify as an active phone user candidate, their account must be active and they must have a phone number but no verified email + isCandidate :: Bool + isCandidate = + ur.activated && ur.status == Just Active && isJust ur.phone && isNothing ur.email + + clientWasActiveLast90Days :: UTCTime -> UTCTime -> Bool + clientWasActiveLast90Days now lastActive = diffUTCTime now lastActive < 90 * nominalDay + + -- if conference_calling is enabled for the team, then it's a paying team + isPayingTeam :: ClientState -> TeamId -> IO Bool + isPayingTeam client tid = do + status <- getConferenceCalling client tid + pure $ case status of + Just FeatureStatusEnabled -> True + Just FeatureStatusDisabled -> False + Nothing -> False + +infoToResult :: UserInfo -> Result +infoToResult = \case + NoPhoneUser -> mempty {usersSearched = 1} + PhoneUser InactiveLast90Days -> mempty {usersSearched = 1, phoneUsersTotal = 1, inactivePhoneUsers = 1} + PhoneUser ActivePersonalUser -> mempty {usersSearched = 1, phoneUsersTotal = 1, activePersonalPhoneUsers = 1} + PhoneUser (ActiveTeamUser Free) -> + Result + { usersSearched = 1, + phoneUsersTotal = 1, + inactivePhoneUsers = 0, + activePersonalPhoneUsers = 0, + activeFreeTeamPhoneUsers = 1, + activePaidTeamPhoneUsers = 0 + } + PhoneUser (ActiveTeamUser Paid) -> + Result + { usersSearched = 1, + phoneUsersTotal = 1, + inactivePhoneUsers = 0, + activePersonalPhoneUsers = 0, + activeFreeTeamPhoneUsers = 0, + activePaidTeamPhoneUsers = 1 + } + +main :: IO () +main = do + opts <- execParser (info (helper <*> optsParser) desc) + logger <- initLogger + brigClient <- initCas opts.brigDb logger + galleyClient <- initCas opts.galleyDb logger + putStrLn "scanning users table..." + res <- process logger opts.limit brigClient galleyClient + Log.info logger $ "result" .= show res + where + initLogger = + Log.new + . Log.setLogLevel Log.Info + . Log.setOutput Log.StdOut + . Log.setFormat Nothing + . Log.setBufSize 0 + $ Log.defSettings + initCas settings l = + C.init + . C.setLogger (C.mkLogger l) + . C.setContacts settings.host [] + . C.setPortNumber (fromIntegral settings.port) + . C.setKeyspace settings.keyspace + . C.setProtocolVersion C.V4 + $ C.defSettings + desc = header "phone-users" <> progDesc "This program scans brig's users table and determines the number of users that can only login by phone/sms" <> fullDesc diff --git a/tools/db/phone-users/src/PhoneUsers/Types.hs b/tools/db/phone-users/src/PhoneUsers/Types.hs new file mode 100644 index 00000000000..fc60a3ee038 --- /dev/null +++ b/tools/db/phone-users/src/PhoneUsers/Types.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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 PhoneUsers.Types where + +import Cassandra as C +import Control.Lens +import qualified Data.Aeson as A +import qualified Data.Aeson.Encode.Pretty as A +import qualified Data.ByteString.Lazy.Char8 as LC8 +import Data.Id +import Data.Text.Strict.Lens +import Database.CQL.Protocol hiding (Result) +import Imports +import Options.Applicative +import Wire.API.User + +data CassandraSettings = CassandraSettings + { host :: String, + port :: Int, + keyspace :: C.Keyspace + } + +data Opts = Opts + { brigDb :: CassandraSettings, + galleyDb :: CassandraSettings, + limit :: Maybe Int + } + +optsParser :: Parser Opts +optsParser = + Opts + <$> brigCassandraParser + <*> galleyCassandraParser + <*> optional + ( option + auto + ( long "limit" + <> short 'l' + <> metavar "INT" + <> help "Limit the number of users to process" + ) + ) + +galleyCassandraParser :: Parser CassandraSettings +galleyCassandraParser = + CassandraSettings + <$> strOption + ( long "galley-cassandra-host" + <> metavar "HOST" + <> help "Cassandra Host for galley" + <> value "localhost" + <> showDefault + ) + <*> option + auto + ( long "galley-cassandra-port" + <> metavar "PORT" + <> help "Cassandra Port for galley" + <> value 9043 + <> showDefault + ) + <*> ( C.Keyspace . view packed + <$> strOption + ( long "galley-cassandra-keyspace" + <> metavar "STRING" + <> help "Cassandra Keyspace for galley" + <> value "galley_test" + <> showDefault + ) + ) + +brigCassandraParser :: Parser CassandraSettings +brigCassandraParser = + CassandraSettings + <$> strOption + ( long "brig-cassandra-host" + <> metavar "HOST" + <> help "Cassandra Host for brig" + <> value "localhost" + <> showDefault + ) + <*> option + auto + ( long "brig-cassandra-port" + <> metavar "PORT" + <> help "Cassandra Port for brig" + <> value 9042 + <> showDefault + ) + <*> ( C.Keyspace . view packed + <$> strOption + ( long "brig-cassandra-keyspace" + <> metavar "STRING" + <> help "Cassandra Keyspace for brig" + <> value "brig_test" + <> showDefault + ) + ) + +data Result = Result + { usersSearched :: Int, + phoneUsersTotal :: Int, + inactivePhoneUsers :: Int, + activePersonalPhoneUsers :: Int, + activeFreeTeamPhoneUsers :: Int, + activePaidTeamPhoneUsers :: Int + } + deriving (Generic) + +instance A.ToJSON Result + +instance Show Result where + show = LC8.unpack . A.encodePretty + +instance Semigroup Result where + r1 <> r2 = + Result + { usersSearched = r1.usersSearched + r2.usersSearched, + phoneUsersTotal = r1.phoneUsersTotal + r2.phoneUsersTotal, + inactivePhoneUsers = r1.inactivePhoneUsers + r2.inactivePhoneUsers, + activePersonalPhoneUsers = r1.activePersonalPhoneUsers + r2.activePersonalPhoneUsers, + activeFreeTeamPhoneUsers = r1.activeFreeTeamPhoneUsers + r2.activeFreeTeamPhoneUsers, + activePaidTeamPhoneUsers = r1.activePaidTeamPhoneUsers + r2.activePaidTeamPhoneUsers + } + +instance Monoid Result where + mempty = + Result + { usersSearched = 0, + phoneUsersTotal = 0, + inactivePhoneUsers = 0, + activePersonalPhoneUsers = 0, + activeFreeTeamPhoneUsers = 0, + activePaidTeamPhoneUsers = 0 + } + +type Activated = Bool + +data UserRow = UserRow + { id :: UserId, + email :: Maybe Email, + phone :: Maybe Phone, + activated :: Activated, + status :: Maybe AccountStatus, + team :: Maybe TeamId + } + deriving (Generic) + +instance A.ToJSON UserRow + +recordInstance ''UserRow + +instance Show UserRow where + show = LC8.unpack . A.encodePretty + +data TeamUser = Free | Paid + deriving (Show) + +data UserInfo = NoPhoneUser | PhoneUser PhoneUserInfo + deriving (Show) + +data PhoneUserInfo + = InactiveLast90Days + | ActivePersonalUser + | ActiveTeamUser TeamUser + deriving (Show) From 40445b56e3477710178903c0e42aeb57aa47f809 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 6 May 2024 09:21:39 +0200 Subject: [PATCH 12/30] Generalise catchErrors middleware (#4037) --- changelog.d/5-internal/federator-request-id | 1 + .../src/Network/Wai/Utilities/Server.hs | 38 ++++++++++++------- services/federator/src/Federator/Response.hs | 5 ++- 3 files changed, 30 insertions(+), 14 deletions(-) create mode 100644 changelog.d/5-internal/federator-request-id diff --git a/changelog.d/5-internal/federator-request-id b/changelog.d/5-internal/federator-request-id new file mode 100644 index 00000000000..4f8c042bfa8 --- /dev/null +++ b/changelog.d/5-internal/federator-request-id @@ -0,0 +1 @@ +Log federator request ID on exceptions diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 80ee4329c13..14fa566c12a 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -31,6 +31,7 @@ module Network.Wai.Utilities.Server -- * Middlewares catchErrors, + catchErrorsWithRequestId, OnErrorMetrics, heavyDebugLogging, rethrow5xx, @@ -184,6 +185,9 @@ route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (lift -------------------------------------------------------------------------------- -- Middlewares +catchErrors :: Logger -> OnErrorMetrics -> Middleware +catchErrors l m = catchErrorsWithRequestId lookupRequestId l m + -- | Create a middleware that catches exceptions and turns -- them into appropriate 'Error' responses, thereby logging -- as well as counting server errors (i.e. exceptions that @@ -191,14 +195,21 @@ route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (lift -- -- This does not log any 'Response' values with error status. -- See 'catchErrors'. -catchErrors :: Logger -> OnErrorMetrics -> Middleware -catchErrors l m app req k = - rethrow5xx l app req k `catch` errorResponse +catchErrorsWithRequestId :: + (Request -> Maybe ByteString) -> + Logger -> + OnErrorMetrics -> + Middleware +catchErrorsWithRequestId getRequestId l m app req k = + rethrow5xx getRequestId l app req k `catch` errorResponse where + mReqId = getRequestId req + errorResponse :: SomeException -> IO ResponseReceived errorResponse ex = do er <- runHandlers ex errorHandlers - onError l m req k er + onError l mReqId m req k er + {-# INLINEABLE catchErrors #-} -- | Standard handlers for turning exceptions into appropriate @@ -298,15 +309,15 @@ emitLByteString lbs = do -- | Run the 'Application'; check the response status; if >=500, throw a 'Wai.Error' with -- label @"server-error"@ and the body as the error message. -rethrow5xx :: Logger -> Middleware -rethrow5xx logger app req k = app req k' +rethrow5xx :: (Request -> Maybe ByteString) -> Logger -> Middleware +rethrow5xx getRequestId logger app req k = app req k' where k' resp@WaiInt.ResponseRaw {} = do -- See Note [Raw Response] let logMsg = field "canoncalpath" (show $ pathInfo req) . field "rawpath" (rawPathInfo req) - . field "request" (fromMaybe "N/A" $ lookupRequestId req) + . field "request" (fromMaybe "N/A" $ getRequestId req) . msg (val "ResponseRaw - cannot collect metrics or log info on errors") Log.log logger Log.Debug logMsg k resp @@ -349,15 +360,16 @@ type OnErrorMetrics = [Either Prm.Counter Metrics] onError :: MonadIO m => Logger -> + Maybe ByteString -> OnErrorMetrics -> Request -> Continue IO -> Either Wai.Error JSONResponse -> m ResponseReceived -onError g m r k e = liftIO $ do +onError g mReqId m r k e = liftIO $ do case e of - Left we -> logError g (Just r) we - Right jr -> logJSONResponse g (Just r) jr + Left we -> logError' g mReqId we + Right jr -> logJSONResponse g mReqId jr let resp = either waiErrorToJSONResponse id e let code = statusCode (resp.status) when (code >= 500) $ @@ -379,9 +391,9 @@ logError' g mr e = liftIO $ doLog g (logErrorMsgWithRequest mr e) | statusCode (Error.code e) >= 500 = Log.err | otherwise = Log.debug -logJSONResponse :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> JSONResponse -> m () -logJSONResponse g mr e = do - let r = fromMaybe "N/A" (mr >>= lookupRequestId) +logJSONResponse :: MonadIO m => Logger -> Maybe ByteString -> JSONResponse -> m () +logJSONResponse g mReqId e = do + let r = fromMaybe "N/A" mReqId liftIO $ doLog g $ field "request" r diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index 6f70df5a390..f4082f93c1a 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -119,7 +119,7 @@ serveServant :: IO () serveServant middleware server env port = Warp.run port - . Wai.catchErrors (view applog env) [] + . Wai.catchErrorsWithRequestId getRequestId (view applog env) [] . middleware $ app where @@ -127,6 +127,9 @@ serveServant middleware server env port = app = genericServe server + getRequestId :: Wai.Request -> Maybe ByteString + getRequestId = lookup "Wire-Origin-Request-Id" . Wai.requestHeaders + type AllEffects = '[ Metrics, Remote, From 9a2fb45a1f7ab62539e522bbb1954ef639c04110 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 8 May 2024 11:51:08 +0200 Subject: [PATCH 13/30] Update mls-test-cli to version 0.12 (#4039) * Update mls-test-cli to version 0.12 * Add CHANGELOG entry --- changelog.d/5-internal/mls-test-cli-update | 1 + nix/pkgs/mls-test-cli/default.nix | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 changelog.d/5-internal/mls-test-cli-update diff --git a/changelog.d/5-internal/mls-test-cli-update b/changelog.d/5-internal/mls-test-cli-update new file mode 100644 index 00000000000..851866f6469 --- /dev/null +++ b/changelog.d/5-internal/mls-test-cli-update @@ -0,0 +1 @@ +Update mls-test-cli to version 0.12 diff --git a/nix/pkgs/mls-test-cli/default.nix b/nix/pkgs/mls-test-cli/default.nix index 115f08511b5..d362e5da0a1 100644 --- a/nix/pkgs/mls-test-cli/default.nix +++ b/nix/pkgs/mls-test-cli/default.nix @@ -7,16 +7,16 @@ rustPlatform.buildRustPackage rec { src = fetchFromGitHub { owner = "wireapp"; repo = "mls-test-cli"; - rev = "0b7bad3a5021d069bcf02aa0d0a3fe0a6fdabe72"; - sha256 = "sha256-bFNqDG2UhN8kOEdGFdhPHN/Wz1y67Wcp1c/z0f0vHfE="; + rev = "c7c416f533417858ff2882dbb5b29f7c090b0470"; + sha256 = "sha256-80k166n7MW0DCtnQ9z0hNgKb9e/nng3aYtSIvoN+Phc="; }; pname = "mls-test-cli"; version = "0.11"; cargoLock = { lockFile = "${src}/Cargo.lock"; outputHashes = { - "hpke-0.10.0" = "sha256-T1+BFwX6allljNZ/8T3mrWhOejnUU27BiWQetqU+0fY="; - "openmls-1.0.0" = "sha256-MOf6F6jy2ofZ05leN9npDAlxYkn2S+hVOq/MSlKWBiU="; + "hpke-0.11.0" = "sha256-58uUnXma50AecSdg+DfT1xkaDimrT53dPmw8M4EIwh8="; + "openmls-1.0.0" = "sha256-iRiUbDZMNf43itWiNascNBscfaIZdwcDdwhJPwYw8Uk="; "safe_pqc_kyber-0.6.2" = "sha256-9t+IIohCJcMIWRtqLA0idyMmjev82BtpST15Tthlge4="; }; }; From 7d5b70ce70db4790629bb191c57a96c962522d1f Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Wed, 8 May 2024 13:31:36 +0200 Subject: [PATCH 14/30] [feat] update the nginz nginx module to support nginx 1.26 (#4042) solves compile errors due to a refactoring done in this commit https://github.com/nginx/nginx/commit/3aef1d693f3cc431563a7e6a6aba6a34e5290f03 --- nix/overlay.nix | 4 ++-- services/nginz/third_party/nginx-zauth-module/zauth_module.c | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/nix/overlay.nix b/nix/overlay.nix index 08dd42c00d0..0d846cb52b0 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -76,10 +76,10 @@ self: super: { }; nginz = (super.nginx.overrideAttrs rec { - version = "1.22.1"; + version = "1.26.0"; src = super.fetchurl { url = "https://nginx.org/download/nginx-${version}.tar.gz"; - hash = "sha256-nrszOp6CuVKs0+K0rrHU/2QG9ySRurbNn+afDepzfzE="; + hash = "sha256-0ubIQ51sbbUBXY6qskcKtSrvhae/NjGCh5l34IQ3BJc="; }; }).override { modules = [ diff --git a/services/nginz/third_party/nginx-zauth-module/zauth_module.c b/services/nginz/third_party/nginx-zauth-module/zauth_module.c index 11e3eba09ec..6c8db823b43 100644 --- a/services/nginz/third_party/nginx-zauth-module/zauth_module.c +++ b/services/nginz/third_party/nginx-zauth-module/zauth_module.c @@ -469,8 +469,8 @@ static ngx_int_t zauth_parse_request (ngx_http_request_t * r) { } else { ngx_str_t name = ngx_string("zprovider"); ngx_str_t cookie = ngx_null_string; - ngx_int_t index = ngx_http_parse_multi_header_lines(&r->headers_in.cookies, &name, &cookie); - if (index != NGX_DECLINED) { + ngx_table_elt_t* cookie_header = ngx_http_parse_multi_header_lines(r, r->headers_in.cookie, &name, &cookie); + if (cookie_header != NULL) { res = zauth_token_parse(cookie.data, cookie.len, &tkn); } } From 4f4891f017227fe98e98180e14f33d4d7ae2b527 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 8 May 2024 15:13:24 +0200 Subject: [PATCH 15/30] gundeck: Fix parsing errors for SNS ARN for VOIP Tokens (#4040) * Revert "Recover "WPB-5204 Remove unused APNS_VOIP code (#3695)" (#3967)" This reverts commit 232a882bbacf6ec2ee482e52df2064ed6ed7413f. * integration: Refactor push token generation for tests This will allow writing tests which want more control over the push tokens * integration: WIP: register push token tests * WIP: migrating test to /integration * integration: finished gundeck token test and delete old test * [gundeck] Refactored addToken to use ExceptT * [gundeck] Returns an error when trying to register VOIP tokens. * format * changelog * wire-api/test/unit: Slightly better error message * Remove ApsPreference --------- Co-authored-by: Igor Ranieri --- changelog.d/3-bug-fixes/gundeck-arn-parsing | 1 + deploy/dockerephemeral/init.sh | 1 + integration/default.nix | 2 + integration/integration.cabal | 2 + integration/test/API/Common.hs | 15 ++- integration/test/API/Gundeck.hs | 91 +++++++++++++----- integration/test/SetupHelpers.hs | 12 +++ integration/test/Test/EJPD.hs | 8 +- integration/test/Test/Presence.hs | 2 +- integration/test/Test/PushToken.hs | 94 +++++++++++++++++++ .../src/Gundeck/Types/Push/V2.hs | 22 +---- libs/wire-api/src/Wire/API/Error/Gundeck.hs | 3 + libs/wire-api/src/Wire/API/Push/V2/Token.hs | 12 ++- .../golden/Test/Wire/API/Golden/Generated.hs | 6 ++ .../Push_2eToken_2eTransport_user.hs | 8 +- .../golden/Test/Wire/API/Golden/Manual.hs | 4 + .../Test/Wire/API/Golden/Manual/Token.hs | 29 ++++++ ...bject_Push_2eToken_2eTransport_user_4.json | 1 + ...bject_Push_2eToken_2eTransport_user_5.json | 1 + .../test/golden/testObject_Token_1.json | 6 ++ libs/wire-api/wire-api.cabal | 1 + services/brig/docs/swagger-v3.json | 4 +- services/brig/docs/swagger-v4.json | 4 +- services/gundeck/src/Gundeck/Aws.hs | 19 +++- services/gundeck/src/Gundeck/Aws/Arn.hs | 4 + services/gundeck/src/Gundeck/Instances.hs | 23 +++-- services/gundeck/src/Gundeck/Push.hs | 85 ++++++++--------- services/gundeck/src/Gundeck/Push/Data.hs | 31 +++--- .../src/Gundeck/Push/Native/Serialise.hs | 9 ++ services/gundeck/test/integration/API.hs | 55 +---------- services/gundeck/test/unit/Native.hs | 2 + 31 files changed, 369 insertions(+), 188 deletions(-) create mode 100644 changelog.d/3-bug-fixes/gundeck-arn-parsing create mode 100644 integration/test/Test/PushToken.hs create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Token.hs create mode 100644 libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_4.json create mode 100644 libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_5.json create mode 100644 libs/wire-api/test/golden/testObject_Token_1.json diff --git a/changelog.d/3-bug-fixes/gundeck-arn-parsing b/changelog.d/3-bug-fixes/gundeck-arn-parsing new file mode 100644 index 00000000000..31a489112a0 --- /dev/null +++ b/changelog.d/3-bug-fixes/gundeck-arn-parsing @@ -0,0 +1 @@ +gundeck: Fix parsing errors for SNS ARN for VOIP Tokens diff --git a/deploy/dockerephemeral/init.sh b/deploy/dockerephemeral/init.sh index 7f11fc7ee0c..676e1b4a106 100755 --- a/deploy/dockerephemeral/init.sh +++ b/deploy/dockerephemeral/init.sh @@ -32,6 +32,7 @@ for suffix in "" "2" "3" "4" "5" "-federation-v0"; do # Create SNS resources for gundeck's notifications exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test$suffix --platform GCM --attributes PlatformCredential=testkey" exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test$suffix --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" + exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test$suffix --platform APNS_VOIP_SANDBOX --attributes PlatformCredential=testprivatekey" exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-com.wire.ent$suffix --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" # Cargohold's bucket; creating a bucket is not idempotent so we just try once and wait until it is ready diff --git a/integration/default.nix b/integration/default.nix index a259708844e..6abbb50c753 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -10,6 +10,7 @@ , async , attoparsec , base +, base16-bytestring , base64-bytestring , bytestring , bytestring-conversion @@ -99,6 +100,7 @@ mkDerivation { async attoparsec base + base16-bytestring base64-bytestring bytestring bytestring-conversion diff --git a/integration/integration.cabal b/integration/integration.cabal index 56bcb614de8..e9563261c78 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -136,6 +136,7 @@ library Test.MLS.Unreachable Test.Notifications Test.Presence + Test.PushToken Test.Roles Test.Search Test.Services @@ -174,6 +175,7 @@ library , async , attoparsec , base + , base16-bytestring , base64-bytestring , bytestring , bytestring-conversion diff --git a/integration/test/API/Common.hs b/integration/test/API/Common.hs index 066c360a422..cdc4b11c2d4 100644 --- a/integration/test/API/Common.hs +++ b/integration/test/API/Common.hs @@ -4,7 +4,8 @@ import Control.Monad import Control.Monad.IO.Class import Data.Array ((!)) import qualified Data.Array as Array -import System.Random (randomRIO) +import qualified Data.ByteString as BS +import System.Random (randomIO, randomRIO) import Testlib.Prelude teamRole :: String -> Int @@ -43,14 +44,24 @@ randomHandleWithRange min' max' = liftIO $ do chars = mkArray $ ['a' .. 'z'] <> ['0' .. '9'] <> "_-." pick = (chars !) <$> randomRIO (Array.bounds chars) +randomBytes :: Int -> App ByteString +randomBytes n = liftIO $ BS.pack <$> replicateM n randomIO + randomHex :: Int -> App String randomHex n = liftIO $ replicateM n pick where chars = mkArray (['0' .. '9'] <> ['a' .. 'f']) pick = (chars !) <$> randomRIO (Array.bounds chars) +-- Should not have leading 0. randomClientId :: App String -randomClientId = randomHex 16 +randomClientId = do + second <- randomHex 15 + first <- pick + pure $ first : second + where + chars = mkArray (['1' .. '9'] <> ['a' .. 'f']) + pick = (chars !) <$> randomRIO (Array.bounds chars) mkArray :: [a] -> Array.Array Int a mkArray l = Array.listArray (0, length l - 1) l diff --git a/integration/test/API/Gundeck.hs b/integration/test/API/Gundeck.hs index 1f2c1a76429..d44603ca2aa 100644 --- a/integration/test/API/Gundeck.hs +++ b/integration/test/API/Gundeck.hs @@ -1,6 +1,9 @@ module API.Gundeck where import API.Common +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Testlib.Prelude data GetNotifications = GetNotifications @@ -58,37 +61,83 @@ getLastNotification user opts = do baseRequest user Gundeck Versioned "/notifications/last" submit "GET" $ req & addQueryParams [("client", c) | c <- toList opts.client] -data PostPushToken = PostPushToken +data GeneratePushToken = GeneratePushToken { transport :: String, app :: String, - token :: Maybe String, tokenSize :: Int } -instance Default PostPushToken where +instance Default GeneratePushToken where def = - PostPushToken + GeneratePushToken { transport = "GCM", app = "test", - token = Nothing, tokenSize = 16 } +generateAndPostPushToken :: + (HasCallStack, MakesValue user, MakesValue client) => + user -> + client -> + GeneratePushToken -> + App Response +generateAndPostPushToken user client args = do + token <- generateToken args.tokenSize + clientId <- make client & asString + postPushToken user $ PushToken args.transport args.app token clientId + +data PushToken = PushToken + { transport :: String, + app :: String, + token :: String, + client :: String + } + deriving (Show, Eq) + +instance ToJSON PushToken where + toJSON pt = + object + [ "transport" .= pt.transport, + "app" .= pt.app, + "token" .= pt.token, + "client" .= pt.client + ] + +instance MakesValue PushToken where + make = pure . toJSON + +generateToken :: Int -> App String +generateToken = + fmap (Text.unpack . Text.decodeUtf8 . Base16.encode) . randomBytes + postPushToken :: - (HasCallStack, MakesValue u, MakesValue c) => - u -> - c -> - PostPushToken -> + ( HasCallStack, + MakesValue token, + MakesValue user + ) => + user -> + token -> App Response -postPushToken u client args = do - req <- baseRequest u Gundeck Versioned "/push/tokens" - token <- maybe (randomHex (args.tokenSize * 2)) pure args.token - c <- make client - let t = - object - [ "transport" .= args.transport, - "app" .= args.app, - "token" .= token, - "client" .= c - ] - submit "POST" $ req & addJSON t +postPushToken user token = do + req <- baseRequest user Gundeck Versioned "/push/tokens" + tokenJson <- make token + submit "POST" $ req & addJSON tokenJson + +listPushTokens :: (MakesValue user) => user -> App Response +listPushTokens user = do + req <- + baseRequest user Gundeck Versioned $ + joinHttpPath ["/push/tokens"] + submit "GET" req + +unregisterClient :: + (MakesValue user, MakesValue client) => + user -> + client -> + App Response +unregisterClient user client = do + cid <- asString client + req <- + baseRequest user Gundeck Unversioned $ + joinHttpPath ["/i/clients", cid] + submit "DELETE" req diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 1d6803e0beb..341505a11de 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -13,12 +13,15 @@ import Control.Monad.Reader import Crypto.Random (getRandomBytes) import Data.Aeson hiding ((.=)) import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64.URL as B64Url import Data.ByteString.Char8 (unpack) import qualified Data.CaseInsensitive as CI import Data.Default import Data.Function import Data.String.Conversions (cs) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) import Data.UUID.V1 (nextUUID) import Data.UUID.V4 (nextRandom) import GHC.Stack @@ -183,6 +186,15 @@ createMLSOne2OnePartner domain other convDomain = loop randomToken :: HasCallStack => App String randomToken = unpack . B64Url.encode <$> liftIO (getRandomBytes 16) +data TokenLength = GCM | APNS + +randomSnsToken :: HasCallStack => TokenLength -> App String +randomSnsToken = \case + GCM -> mkTok 16 + APNS -> mkTok 32 + where + mkTok = fmap (Text.unpack . decodeUtf8 . Base16.encode) . randomBytes + randomId :: HasCallStack => App String randomId = liftIO (show <$> nextRandom) diff --git a/integration/test/Test/EJPD.hs b/integration/test/Test/EJPD.hs index b20e74a6634..36301a9cb96 100644 --- a/integration/test/Test/EJPD.hs +++ b/integration/test/Test/EJPD.hs @@ -44,23 +44,23 @@ setupEJPD = toks1 <- do cl11 <- objId $ addClient (usr1 %. "qualified_id") def >>= getJSON 201 - bindResponse (postPushToken usr1 cl11 def) $ \resp -> do + bindResponse (generateAndPostPushToken usr1 cl11 def) $ \resp -> do resp.status `shouldMatchInt` 201 tok <- resp.json %. "token" & asString pure [tok] toks2 <- do cl21 <- objId $ addClient (usr2 %. "qualified_id") def >>= getJSON 201 cl22 <- objId $ addClient (usr2 %. "qualified_id") def >>= getJSON 201 - t1 <- bindResponse (postPushToken usr2 cl21 def) $ \resp -> do + t1 <- bindResponse (generateAndPostPushToken usr2 cl21 def) $ \resp -> do resp.status `shouldMatchInt` 201 resp.json %. "token" & asString - t2 <- bindResponse (postPushToken usr2 cl22 def) $ \resp -> do + t2 <- bindResponse (generateAndPostPushToken usr2 cl22 def) $ \resp -> do resp.status `shouldMatchInt` 201 resp.json %. "token" & asString pure [t1, t2] toks4 <- do cl41 <- objId $ addClient (usr4 %. "qualified_id") def >>= getJSON 201 - bindResponse (postPushToken usr4 cl41 def) $ \resp -> do + bindResponse (generateAndPostPushToken usr4 cl41 def) $ \resp -> do resp.status `shouldMatchInt` 201 tok <- resp.json %. "token" & asString pure [tok] diff --git a/integration/test/Test/Presence.hs b/integration/test/Test/Presence.hs index a733d2bb539..e6252ea7e2a 100644 --- a/integration/test/Test/Presence.hs +++ b/integration/test/Test/Presence.hs @@ -27,7 +27,7 @@ testRemoveUser :: HasCallStack => App () testRemoveUser = do -- register alice and add a push token (alice, c) <- registerUser - void $ postPushToken alice c def >>= getJSON 201 + void $ generateAndPostPushToken alice c def >>= getJSON 201 do t <- getPushTokens alice >>= getJSON 200 tokens <- t %. "tokens" & asList diff --git a/integration/test/Test/PushToken.hs b/integration/test/Test/PushToken.hs new file mode 100644 index 00000000000..24f30573b03 --- /dev/null +++ b/integration/test/Test/PushToken.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module Test.PushToken where + +import API.Common +import API.Gundeck +import SetupHelpers +import Testlib.Prelude + +testRegisterPushToken :: App () +testRegisterPushToken = do + alice <- randomUser OwnDomain def + aliceC2 <- randomClientId + aliceC1 <- randomClientId + + -- Client 1 with 4 tokens + c1Apns1 <- randomSnsToken APNS + c1Apns1Overlap <- randomSnsToken APNS + c1Apns2 <- randomSnsToken APNS + c1Gcm1 <- randomSnsToken GCM + + -- Client 2 with 1 token + c2Apns1 <- randomSnsToken APNS + c2Gcm1 <- randomSnsToken GCM + c2Gcm1Overlap <- randomSnsToken GCM + + let apnsToken = PushToken "APNS_SANDBOX" "test" + let gcmToken = PushToken "GCM" "test" + + let c1Apns1Token = apnsToken c1Apns1 aliceC1 + let c1Apns1OverlapToken = apnsToken c1Apns1Overlap aliceC1 + let c1Apns2Token = (apnsToken c1Apns2 aliceC1 :: PushToken) {app = "com.wire.ent"} -- diff app prevents overlap + let c1Gcm1Token = gcmToken c1Gcm1 aliceC1 + + let c2Apns1Token = apnsToken c2Apns1 aliceC2 + let c2Gcm1Token = gcmToken c2Gcm1 aliceC2 + let c2Gcm1OverlapToken = gcmToken c2Gcm1Overlap aliceC2 + + -- Register non-overlapping tokens for client 1 + assertStatus 201 =<< (postPushToken alice c1Apns1Token) + assertStatus 201 =<< (postPushToken alice c1Apns2Token) + assertStatus 201 =<< (postPushToken alice c1Gcm1Token) + + -- register non-overlapping tokens for client 2 + assertStatus 201 =<< (postPushToken alice c2Apns1Token) + assertStatus 201 =<< (postPushToken alice c2Gcm1Token) + + bindResponse (listPushTokens alice) \resp -> do + resp.status `shouldMatchInt` 200 + allTokens <- resp.json %. "tokens" + allTokens + `shouldMatchSet` [ c1Apns1Token, + c1Apns2Token, + c1Gcm1Token, + c2Apns1Token, + c2Gcm1Token + ] + + -- Resistering an overlapping token overwrites it. + assertStatus 201 =<< postPushToken alice c1Apns1OverlapToken + assertStatus 201 =<< postPushToken alice c2Gcm1OverlapToken + + bindResponse (listPushTokens alice) \resp -> do + resp.status `shouldMatchInt` 200 + allTokens <- resp.json %. "tokens" + allTokens + `shouldMatchSet` [ c1Apns1OverlapToken, + c1Apns2Token, + c1Gcm1Token, + c2Apns1Token, + c2Gcm1OverlapToken + ] + + -- Push tokens are deleted alongside clients + assertStatus 200 =<< unregisterClient alice aliceC1 + assertStatus 200 =<< unregisterClient alice aliceC2 + + bindResponse (listPushTokens alice) \resp -> do + resp.status `shouldMatchInt` 200 + allTokens <- resp.json %. "tokens" + allTokens + `shouldMatchSet` ([] :: [PushToken]) + +testVoipTokenRegistrationFails :: App () +testVoipTokenRegistrationFails = do + alice <- randomUser OwnDomain def + aliceC2 <- randomClientId + + token <- randomSnsToken APNS + let apnsVoipToken = PushToken "APNS_VOIP_SANDBOX" "test" token aliceC2 + postPushToken alice apnsVoipToken `bindResponse` \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "apns-voip-not-supported" diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index c087d911135..b8794553a45 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -45,14 +45,12 @@ module Gundeck.Types.Push.V2 recipientClients, Route (..), ApsData, - ApsPreference (..), ApsLocKey (..), ApsSound (..), apsData, apsLocKey, apsLocArgs, apsSound, - apsPreference, apsBadge, -- * Priority (re-export) @@ -176,24 +174,10 @@ newtype ApsSound = ApsSound {fromSound :: Text} newtype ApsLocKey = ApsLocKey {fromLocKey :: Text} deriving (Eq, Show, ToJSON, FromJSON, Arbitrary) -data ApsPreference - = ApsStdPreference - deriving (Eq, Show, Generic) - deriving (Arbitrary) via GenericUniform ApsPreference - -instance ToJSON ApsPreference where - toJSON ApsStdPreference = "std" - -instance FromJSON ApsPreference where - parseJSON = withText "ApsPreference" $ \case - "std" -> pure ApsStdPreference - x -> fail $ "Invalid preference: " ++ show x - data ApsData = ApsData { _apsLocKey :: !ApsLocKey, _apsLocArgs :: [Text], _apsSound :: !(Maybe ApsSound), - _apsPreference :: !(Maybe ApsPreference), _apsBadge :: !Bool } deriving (Eq, Show, Generic) @@ -202,15 +186,14 @@ data ApsData = ApsData makeLenses ''ApsData apsData :: ApsLocKey -> [Text] -> ApsData -apsData lk la = ApsData lk la Nothing Nothing True +apsData lk la = ApsData lk la Nothing True instance ToJSON ApsData where - toJSON (ApsData k a s p b) = + toJSON (ApsData k a s b) = object $ "loc_key" .= k # "loc_args" .= a # "sound" .= s - # "preference" .= p # "badge" .= b # [] @@ -220,7 +203,6 @@ instance FromJSON ApsData where <$> o .: "loc_key" <*> o .:? "loc_args" .!= [] <*> o .:? "sound" - <*> o .:? "preference" <*> o .:? "badge" .!= True ----------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Error/Gundeck.hs b/libs/wire-api/src/Wire/API/Error/Gundeck.hs index ac9b6ce363f..2fa60fbad31 100644 --- a/libs/wire-api/src/Wire/API/Error/Gundeck.hs +++ b/libs/wire-api/src/Wire/API/Error/Gundeck.hs @@ -26,6 +26,7 @@ data GundeckError | AddTokenErrorInvalid | AddTokenErrorTooLong | AddTokenErrorMetadataTooLong + | AddTokenErrorApnsVoipNotSupported | TokenNotFound | NotificationNotFound @@ -42,6 +43,8 @@ type instance MapError 'AddTokenErrorTooLong = 'StaticError 413 "token-too-long" type instance MapError 'AddTokenErrorMetadataTooLong = 'StaticError 413 "metadata-too-long" "Tried to add token to endpoint resulting in metadata length > 2048" +type instance MapError 'AddTokenErrorApnsVoipNotSupported = 'StaticError 400 "apns-voip-not-supported" "Adding APNS_VOIP tokens is not supported" + type instance MapError 'TokenNotFound = 'StaticError 404 "not-found" "Push token not found" type instance MapError 'NotificationNotFound = 'StaticError 404 "not-found" "Some notifications not found" diff --git a/libs/wire-api/src/Wire/API/Push/V2/Token.hs b/libs/wire-api/src/Wire/API/Push/V2/Token.hs index 79f282b4d0f..29560be5fe8 100644 --- a/libs/wire-api/src/Wire/API/Push/V2/Token.hs +++ b/libs/wire-api/src/Wire/API/Push/V2/Token.hs @@ -115,6 +115,8 @@ data Transport = GCM | APNS | APNSSandbox + | APNSVoIP + | APNSVoIPSandbox deriving stock (Eq, Ord, Show, Bounded, Enum, Generic) deriving (Arbitrary) via (GenericUniform Transport) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Transport) @@ -125,7 +127,9 @@ instance ToSchema Transport where mconcat [ element "GCM" GCM, element "APNS" APNS, - element "APNS_SANDBOX" APNSSandbox + element "APNS_SANDBOX" APNSSandbox, + element "APNS_VOIP" APNSVoIP, + element "APNS_VOIP_SANDBOX" APNSVoIPSandbox ] instance FromByteString Transport where @@ -134,6 +138,8 @@ instance FromByteString Transport where "GCM" -> pure GCM "APNS" -> pure APNS "APNS_SANDBOX" -> pure APNSSandbox + "APNS_VOIP" -> pure APNSVoIP + "APNS_VOIP_SANDBOX" -> pure APNSVoIPSandbox x -> fail $ "Invalid push transport: " <> show x newtype Token = Token @@ -169,7 +175,8 @@ type AddTokenErrorResponses = ErrorResponse 'E.AddTokenErrorNotFound, ErrorResponse 'E.AddTokenErrorInvalid, ErrorResponse 'E.AddTokenErrorTooLong, - ErrorResponse 'E.AddTokenErrorMetadataTooLong + ErrorResponse 'E.AddTokenErrorMetadataTooLong, + ErrorResponse 'E.AddTokenErrorApnsVoipNotSupported ] type AddTokenSuccessResponses = @@ -187,6 +194,7 @@ data AddTokenError | AddTokenErrorInvalid | AddTokenErrorTooLong | AddTokenErrorMetadataTooLong + | AddTokenErrorApnsVoipNotSupported deriving (Show, Generic) deriving (AsUnion AddTokenErrorResponses) via GenericAsUnion AddTokenErrorResponses AddTokenError 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 8940de2043c..9778eec5ec5 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 @@ -806,6 +806,12 @@ tests = ), ( Test.Wire.API.Golden.Generated.Push_2eToken_2eTransport_user.testObject_Push_2eToken_2eTransport_user_3, "testObject_Push_2eToken_2eTransport_user_3.json" + ), + ( Test.Wire.API.Golden.Generated.Push_2eToken_2eTransport_user.testObject_Push_2eToken_2eTransport_user_4, + "testObject_Push_2eToken_2eTransport_user_4.json" + ), + ( Test.Wire.API.Golden.Generated.Push_2eToken_2eTransport_user.testObject_Push_2eToken_2eTransport_user_5, + "testObject_Push_2eToken_2eTransport_user_5.json" ) ], testGroup "Golden: Token_user" $ diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs index fc7c1ed7f14..96739ba620c 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs @@ -17,7 +17,7 @@ module Test.Wire.API.Golden.Generated.Push_2eToken_2eTransport_user where -import Wire.API.Push.Token (Transport (APNS, APNSSandbox, GCM)) +import Wire.API.Push.Token (Transport (APNS, APNSSandbox, APNSVoIP, APNSVoIPSandbox, GCM)) import Wire.API.Push.Token qualified as Push.Token (Transport) testObject_Push_2eToken_2eTransport_user_1 :: Push.Token.Transport @@ -28,3 +28,9 @@ testObject_Push_2eToken_2eTransport_user_2 = APNS testObject_Push_2eToken_2eTransport_user_3 :: Push.Token.Transport testObject_Push_2eToken_2eTransport_user_3 = APNSSandbox + +testObject_Push_2eToken_2eTransport_user_4 :: Push.Token.Transport +testObject_Push_2eToken_2eTransport_user_4 = APNSVoIP + +testObject_Push_2eToken_2eTransport_user_5 :: Push.Token.Transport +testObject_Push_2eToken_2eTransport_user_5 = APNSVoIPSandbox diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index ffb00e875b7..57daad1dd22 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -43,6 +43,7 @@ import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap import Test.Wire.API.Golden.Manual.SearchResultContact import Test.Wire.API.Golden.Manual.SubConversation import Test.Wire.API.Golden.Manual.TeamSize +import Test.Wire.API.Golden.Manual.Token import Test.Wire.API.Golden.Manual.UserClientPrekeyMap import Test.Wire.API.Golden.Manual.UserEvent import Test.Wire.API.Golden.Manual.UserIdList @@ -147,6 +148,9 @@ tests = testGroup "GroupId" $ testObjects [(testObject_GroupId_1, "testObject_GroupId_1.json")], + testGroup "PushToken" $ + testObjects + [(testObject_Token_1, "testObject_Token_1.json")], testGroup "TeamSize" $ testObjects [ (testObject_TeamSize_1, "testObject_TeamSize_1.json"), diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Token.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Token.hs new file mode 100644 index 00000000000..2fa8207ddc9 --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Token.hs @@ -0,0 +1,29 @@ +-- 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 Test.Wire.API.Golden.Manual.Token where + +import Data.Id +import Wire.API.Push.V2.Token + +testObject_Token_1 :: PushToken +testObject_Token_1 = + pushToken + APNSVoIPSandbox + (AppName {appNameText = "j{\110746\SOH_\1084873M"}) + (Token {tokenText = "K"}) + (ClientId {clientToWord64 = 6}) diff --git a/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_4.json b/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_4.json new file mode 100644 index 00000000000..d177fe0e9d7 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_4.json @@ -0,0 +1 @@ +"APNS_VOIP" diff --git a/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_5.json b/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_5.json new file mode 100644 index 00000000000..fd689b4ac10 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Push_2eToken_2eTransport_user_5.json @@ -0,0 +1 @@ +"APNS_VOIP_SANDBOX" diff --git a/libs/wire-api/test/golden/testObject_Token_1.json b/libs/wire-api/test/golden/testObject_Token_1.json new file mode 100644 index 00000000000..36f8ff69bd8 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_Token_1.json @@ -0,0 +1,6 @@ +{ + "app": "j{𛂚\u0001_􈷉M", + "client": "6", + "token": "K", + "transport": "APNS_VOIP_SANDBOX" +} diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 3ea6d980ab9..9c9087dcf58 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -593,6 +593,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.SearchResultContact Test.Wire.API.Golden.Manual.SubConversation Test.Wire.API.Golden.Manual.TeamSize + Test.Wire.API.Golden.Manual.Token Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserEvent Test.Wire.API.Golden.Manual.UserIdList diff --git a/services/brig/docs/swagger-v3.json b/services/brig/docs/swagger-v3.json index b844341e756..e252a739717 100644 --- a/services/brig/docs/swagger-v3.json +++ b/services/brig/docs/swagger-v3.json @@ -14,7 +14,9 @@ "enum": [ "GCM", "APNS", - "APNS_SANDBOX" + "APNS_SANDBOX", + "APNS_VOIP", + "APNS_VOIP_SANDBOX" ], "type": "string" }, diff --git a/services/brig/docs/swagger-v4.json b/services/brig/docs/swagger-v4.json index 7ff1394f344..937aafdefc9 100644 --- a/services/brig/docs/swagger-v4.json +++ b/services/brig/docs/swagger-v4.json @@ -4828,7 +4828,9 @@ "enum": [ "GCM", "APNS", - "APNS_SANDBOX" + "APNS_SANDBOX", + "APNS_VOIP", + "APNS_VOIP_SANDBOX" ], "type": "string" }, diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index b1636f33b7c..ea5fe968866 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -369,12 +369,17 @@ newtype Attributes = Attributes -- Note [VoIP TTLs] -- ~~~~~~~~~~~~~~~~ --- For GCM, APNS and APNS_SANDBOX, SNS treats the TTL "0" +-- The TTL message attributes for APNS_VOIP and APNS_VOIP_SANDBOX are not +-- documented but appear to work. The reason might be that TTLs were +-- introduced before support for VoIP notifications. There is a catch, +-- however. For GCM, APNS and APNS_SANDBOX, SNS treats the TTL "0" -- specially, i.e. it forwards it to the provider where it has a special --- meaning. Which means if the TTL is lower than the "dwell time" in SNS, --- the notification is never sent to the provider. So we must specify a --- reasonably large TTL for transient VoIP notifications, so that they are --- not discarded already by SNS. +-- meaning. That does not appear to be the case for APNS_VOIP and +-- APNS_VOIP_SANDBOX, for which the TTL is interpreted normally, which means +-- if the TTL is lower than the "dwell time" in SNS, the notification is +-- never sent to the provider. So we must specify a reasonably large TTL +-- for transient VoIP notifications, so that they are not discarded +-- already by SNS. -- -- cf. http://docs.aws.amazon.com/sns/latest/dg/sns-ttl.html @@ -390,9 +395,13 @@ timeToLive t s = Attributes (Endo (ttlAttr s)) 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 diff --git a/services/gundeck/src/Gundeck/Aws/Arn.hs b/services/gundeck/src/Gundeck/Aws/Arn.hs index 6c09b4bf362..17588d08106 100644 --- a/services/gundeck/src/Gundeck/Aws/Arn.hs +++ b/services/gundeck/src/Gundeck/Aws/Arn.hs @@ -135,6 +135,8 @@ arnTransportText :: Transport -> Text arnTransportText GCM = "GCM" arnTransportText APNS = "APNS" arnTransportText APNSSandbox = "APNS_SANDBOX" +arnTransportText APNSVoIP = "APNS_VOIP" +arnTransportText APNSVoIPSandbox = "APNS_VOIP_SANDBOX" -- Parsers -------------------------------------------------------------------- @@ -163,5 +165,7 @@ endpointTopicParser = do transportParser :: Parser Transport transportParser = string "GCM" $> GCM + <|> string "APNS_VOIP_SANDBOX" $> APNSVoIPSandbox + <|> string "APNS_VOIP" $> APNSVoIP <|> string "APNS_SANDBOX" $> APNSSandbox <|> string "APNS" $> APNS diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs index 8b5b334f15f..83ab2a692b4 100644 --- a/services/gundeck/src/Gundeck/Instances.hs +++ b/services/gundeck/src/Gundeck/Instances.hs @@ -34,22 +34,21 @@ import Gundeck.Aws.Arn (EndpointArn) import Gundeck.Types import Imports --- | We provide a instance for `Either Int Transport` so we can handle (ie., gracefully ignore --- rather than crash on) deprecated values in cassandra. See "Gundeck.Push.Data". -instance Cql (Either Int32 Transport) where +instance Cql Transport where ctype = Tagged IntColumn - toCql (Right GCM) = CqlInt 0 - toCql (Right APNS) = CqlInt 1 - toCql (Right APNSSandbox) = CqlInt 2 - toCql (Left i) = CqlInt i -- (this is weird, but it's helpful for cleaning up deprecated tokens.) + toCql GCM = CqlInt 0 + toCql APNS = CqlInt 1 + toCql APNSSandbox = CqlInt 2 + toCql APNSVoIP = CqlInt 3 + toCql APNSVoIPSandbox = CqlInt 4 fromCql (CqlInt i) = case i of - 0 -> pure $ Right GCM - 1 -> pure $ Right APNS - 2 -> pure $ Right APNSSandbox - 3 -> pure (Left 3) -- `APNSVoIPV1` tokens are deprecated and will be ignored - 4 -> pure (Left 4) -- `APNSVoIPSandboxV1` tokens are deprecated and will be ignored + 0 -> pure GCM + 1 -> pure APNS + 2 -> pure APNSSandbox + 3 -> pure APNSVoIP + 4 -> pure APNSVoIPSandbox n -> Left $ "unexpected transport: " ++ show n fromCql _ = Left "transport: int expected" diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 3e6fa5c05c6..b11785fa770 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -36,6 +36,7 @@ import Control.Error import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens (to, view, (.~), (^.)) import Control.Monad.Catch +import Control.Monad.Except (throwError) import Data.Aeson as Aeson (Object) import Data.Id import Data.List.Extra qualified as List @@ -350,10 +351,7 @@ nativeTargets psh rcps' alreadySent = addresses :: Recipient -> m [Address] addresses u = do addrs <- mntgtLookupAddresses (u ^. recipientId) - pure - $ preference - . filter (eligible u) - $ addrs + pure $ filter (eligible u) addrs eligible :: Recipient -> Address -> Bool eligible u a -- Never include the origin client. @@ -373,17 +371,7 @@ nativeTargets psh rcps' alreadySent = whitelistedOrNoWhitelist a = null (psh ^. pushConnections) || a ^. addrConn `elem` psh ^. pushConnections - -- Apply transport preference in case of alternative transports for the - -- same client. If no explicit preference is given, the default preference depends on the priority. - preference as = - let pref = psh ^. pushNativeAps >>= view apsPreference - in filter (pick (fromMaybe defPreference pref)) as - where - pick pr a = case a ^. addrTransport of - GCM -> True - APNS -> pr == ApsStdPreference - APNSSandbox -> pr == ApsStdPreference - defPreference = ApsStdPreference + check :: Either SomeException [a] -> m [a] check (Left e) = mntgtLogErr e >> pure [] check (Right r) = pure r @@ -391,21 +379,21 @@ nativeTargets psh rcps' alreadySent = type AddTokenResponse = Either Public.AddTokenError Public.AddTokenSuccess addToken :: UserId -> ConnId -> PushToken -> Gundeck AddTokenResponse -addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) $ do - (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum - Log.info $ - "user" - .= UUID.toASCIIBytes (toUUID uid) - ~~ "token" - .= Text.take 16 (tokenText (newtok ^. token)) - ~~ msg (val "Registering push token") - continue newtok cur - >>= either - pure - ( \a -> do - Native.deleteTokens old (Just a) - pure (Right $ Public.AddTokenSuccess newtok) - ) +addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) $ runExceptT $ do + when (newtok ^. tokenTransport `elem` [APNSVoIP, APNSVoIPSandbox]) $ + throwError Public.AddTokenErrorApnsVoipNotSupported + + (cur, old) <- lift $ foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum + lift $ + Log.info $ + "user" + .= UUID.toASCIIBytes (toUUID uid) + ~~ "token" + .= Text.take 16 (tokenText (newtok ^. token)) + ~~ msg (val "Registering push token") + addr <- continue newtok cur + lift $ Native.deleteTokens old (Just addr) + pure $ Public.AddTokenSuccess newtok where matching :: PushToken -> @@ -424,14 +412,14 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) continue :: PushToken -> Maybe Address -> - Gundeck (Either AddTokenResponse Address) + ExceptT Public.AddTokenError Gundeck Address continue t Nothing = create (0 :: Int) t continue t (Just a) = update (0 :: Int) t (a ^. addrEndpoint) create :: Int -> PushToken -> - Gundeck (Either AddTokenResponse Address) + ExceptT Public.AddTokenError Gundeck Address create n t = do let trp = t ^. tokenTransport let app = t ^. tokenApp @@ -441,32 +429,33 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) ept <- Aws.execute aws' (Aws.createEndpoint uid trp env app tok) case ept of Left (Aws.EndpointInUse arn) -> do - Log.info $ "arn" .= toText arn ~~ msg (val "ARN in use") + lift $ Log.info $ "arn" .= toText arn ~~ msg (val "ARN in use") update (n + 1) t arn Left (Aws.AppNotFound app') -> do - Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'") - pure (Left (Left Public.AddTokenErrorNotFound)) + lift $ Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'") + throwError Public.AddTokenErrorNotFound Left (Aws.InvalidToken _) -> do - Log.info $ - "token" - .= tokenText tok - ~~ msg (val "Invalid push token.") - pure (Left (Left Public.AddTokenErrorInvalid)) + lift $ + Log.info $ + "token" + .= tokenText tok + ~~ msg (val "Invalid push token.") + throwError Public.AddTokenErrorInvalid Left (Aws.TokenTooLong l) -> do - Log.info $ msg ("Push token is too long: token length = " ++ show l) - pure (Left (Left Public.AddTokenErrorTooLong)) + lift $ Log.info $ msg ("Push token is too long: token length = " ++ show l) + throwError Public.AddTokenErrorTooLong Right arn -> do Data.insert uid trp app tok arn cid (t ^. tokenClient) - pure (Right (mkAddr t arn)) + pure $ mkAddr t arn update :: Int -> PushToken -> SnsArn EndpointTopic -> - Gundeck (Either AddTokenResponse Address) + ExceptT Public.AddTokenError Gundeck Address update n t arn = do when (n >= 3) $ do - Log.err $ msg (val "AWS SNS inconsistency w.r.t. " +++ toText arn) + lift $ Log.err $ msg (val "AWS SNS inconsistency w.r.t. " +++ toText arn) throwM (mkError status500 "server-error" "Server Error") aws' <- view awsEnv ept <- Aws.execute aws' (Aws.lookupEndpoint arn) @@ -474,7 +463,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) Nothing -> create (n + 1) t Just ep -> do - updateEndpoint uid t arn ep + lift $ updateEndpoint uid t arn ep Data.insert uid (t ^. tokenTransport) @@ -483,7 +472,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) arn cid (t ^. tokenClient) - pure (Right (mkAddr t arn)) + pure $ mkAddr t arn `catch` \case -- Note: If the endpoint was recently deleted (not necessarily -- concurrently), we may get an EndpointNotFound error despite @@ -492,7 +481,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) -- possibly updates in general). We make another attempt to (re-)create -- the endpoint in these cases instead of failing immediately. Aws.EndpointNotFound {} -> create (n + 1) t - Aws.InvalidCustomData {} -> pure (Left (Left Public.AddTokenErrorMetadataTooLong)) + Aws.InvalidCustomData {} -> throwError Public.AddTokenErrorMetadataTooLong ex -> throwM ex mkAddr :: diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs index fa495b0e1fe..c688f64f4db 100644 --- a/services/gundeck/src/Gundeck/Push/Data.hs +++ b/services/gundeck/src/Gundeck/Push/Data.hs @@ -38,29 +38,26 @@ import System.Logger.Class qualified as Log lookup :: (MonadClient m, MonadLogger m) => UserId -> Consistency -> m [Address] lookup u c = foldM mk [] =<< retry x1 (query q (params c (Identity u))) where - q :: PrepQuery R (Identity UserId) (UserId, Either Int32 Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) + q :: PrepQuery R (Identity UserId) (UserId, Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) q = "select usr, transport, app, ptoken, arn, connection, client from user_push where usr = ?" mk as r = maybe as (: as) <$> mkAddr r insert :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m () -insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, Right t, a, p, e, o, c)) +insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, t, a, p, e, o, c)) where - q :: PrepQuery W (UserId, Either Int32 Transport, AppName, Token, EndpointArn, ConnId, ClientId) () + q :: PrepQuery W (UserId, Transport, AppName, Token, EndpointArn, ConnId, ClientId) () q = "insert into user_push (usr, transport, app, ptoken, arn, connection, client) values (?, ?, ?, ?, ?, ?, ?)" updateArn :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> m () -updateArn uid transport app token arn = retry x5 $ write q (params LocalQuorum (arn, uid, Right transport, app, token)) +updateArn uid transport app token arn = retry x5 $ write q (params LocalQuorum (arn, uid, transport, app, token)) where - q :: PrepQuery W (EndpointArn, UserId, Either Int32 Transport, AppName, Token) () + q :: PrepQuery W (EndpointArn, UserId, Transport, AppName, Token) () q = {- `IF EXISTS`, but that requires benchmarking -} "update user_push set arn = ? where usr = ? and transport = ? and app = ? and ptoken = ?" delete :: MonadClient m => UserId -> Transport -> AppName -> Token -> m () -delete u t = deleteAux u (Right t) - -deleteAux :: MonadClient m => UserId -> Either Int32 Transport -> AppName -> Token -> m () -deleteAux u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p)) +delete u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p)) where - q :: PrepQuery W (UserId, Either Int32 Transport, AppName, Token) () + q :: PrepQuery W (UserId, Transport, AppName, Token) () q = "delete from user_push where usr = ? and transport = ? and app = ? and ptoken = ?" erase :: MonadClient m => UserId -> m () @@ -71,20 +68,16 @@ erase u = retry x5 $ write q (params LocalQuorum (Identity u)) mkAddr :: (MonadClient m, MonadLogger m) => - (UserId, Either Int32 Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) -> + (UserId, Transport, AppName, Token, Maybe EndpointArn, ConnId, Maybe ClientId) -> m (Maybe Address) -mkAddr (usr, trp, app, tok, arn, con, clt) = case (trp, clt, arn) of - (Right t, Just c, Just a) -> pure $! Just $! Address usr a con (pushToken t app tok c) +mkAddr (usr, trp, app, tok, arn, con, clt) = case (clt, arn) of + (Just c, Just a) -> pure $! Just $! Address usr a con (pushToken trp app tok c) _ -> do Log.info $ field "user" (toByteString usr) ~~ field "transport" (show trp) ~~ field "app" (appNameText app) ~~ field "token" (tokenText tok) - ~~ msg - ( val - "Deleting legacy push token without a client or ARN, or with deprecated \ - \APNSVoIP* transports (transport type not shown in this message)." - ) - deleteAux usr trp app tok + ~~ msg (val "Deleting legacy push token without a client or ARN.") + delete usr trp app tok pure Nothing diff --git a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs index 07f783c36d9..bf9e0e491cc 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs @@ -54,6 +54,8 @@ renderText t prio x = case t of GCM -> trim "GCM" (jsonString gcmJson) APNS -> trim "APNS" (jsonString stdApnsJson) APNSSandbox -> trim "APNS_SANDBOX" (jsonString stdApnsJson) + APNSVoIP -> trim "APNS_VOIP" (jsonString voipApnsJson) + APNSVoIPSandbox -> trim "APNS_VOIP_SANDBOX" (jsonString voipApnsJson) where gcmJson = object @@ -65,6 +67,11 @@ renderText t prio x = case t of [ "aps" .= apsDict, "data" .= x ] + voipApnsJson = + object + [ "aps" .= object [], + "data" .= x + ] -- https://developer.apple.com/documentation/usernotifications/modifying_content_in_newly_delivered_notifications -- Must contain `mutable-content: 1` and include an alert dictionary with title, subtitle, or body information. -- Since we have no useful data here, we send a default payload that gets overridden by the client @@ -87,6 +94,8 @@ maxPayloadSize :: Transport -> Int64 maxPayloadSize GCM = 4096 maxPayloadSize APNS = 4096 maxPayloadSize APNSSandbox = 4096 +maxPayloadSize APNSVoIP = 5120 +maxPayloadSize APNSVoIPSandbox = 5120 gcmPriority :: Priority -> Text gcmPriority LowPriority = "normal" diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 0d9f128b4ae..a91a075ac00 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -106,8 +106,7 @@ tests s = ], testGroup "Tokens" - [ test s "register a push token" testRegisterPushToken, - test s "unregister a push token" testUnregisterPushToken + [ test s "unregister a push token" testUnregisterPushToken ], testGroup "Websocket pingpong" @@ -724,49 +723,6 @@ testUnregisterClient = do -- ${env}-test (FCM), ${env}-test (APNS_SANDBOX), ${env}-com.wire.ent (APNS_SANDBOX), -- with ${env} normally being integration. -testRegisterPushToken :: TestM () -testRegisterPushToken = do - g <- view tsGundeck - uid <- randomUser - -- Client 1 with 4 distinct tokens - c1 <- randomClientId - t11 <- randomToken c1 apnsToken - t11' <- randomToken c1 apnsToken -- overlaps - t12 <- randomToken c1 apnsToken {tName = AppName "com.wire.ent"} -- different app - t13 <- randomToken c1 gcmToken -- different transport - - -- Client 2 with 1 token - c2 <- randomClientId - t21 <- randomToken c2 apnsToken - t22 <- randomToken c2 gcmToken -- different transport - t22' <- randomToken c2 gcmToken -- overlaps - - -- Register non-overlapping tokens - _ <- registerPushToken uid t11 - _ <- registerPushToken uid t12 - _ <- registerPushToken uid t13 - _ <- registerPushToken uid t21 - _ <- registerPushToken uid t22 - -- Check tokens - _tokens <- sortPushTokens <$> listPushTokens uid - let _expected = sortPushTokens [t11, t12, t13, t21, t22] - liftIO $ assertEqual "unexpected tokens" _expected _tokens - -- Register overlapping tokens. The previous overlapped - -- tokens should be removed, but none of the others. - _ <- registerPushToken uid t11' - _ <- registerPushToken uid t22' - -- Check tokens - _tokens <- sortPushTokens <$> listPushTokens uid - let _expected = sortPushTokens [t11', t12, t13, t21, t22'] - liftIO $ assertEqual "unexpected tokens" _expected _tokens - -- Native push tokens are deleted together with the client - unregisterClient g uid c1 !!! const 200 === statusCode - unregisterClient g uid c1 !!! const 200 === statusCode -- (deleting a non-existing token is ok.) - unregisterClient g uid c2 !!! const 200 === statusCode - unregisterClient g uid c2 !!! const 200 === statusCode -- (deleting a non-existing token is ok.) - _tokens <- listPushTokens uid - liftIO $ assertEqual "unexpected tokens" [] _tokens - -- TODO: Try to make this test more performant, this test takes too long right now testRegisterTooManyTokens :: TestM () testRegisterTooManyTokens = do @@ -838,8 +794,9 @@ testSharePushToken = do gcmTok <- Token . T.decodeUtf8 . toByteString' <$> randomId apsTok <- Token . T.decodeUtf8 . B16.encode <$> randomBytes 32 let tok1 = pushToken GCM "test" gcmTok - let tok2 = pushToken APNS "com.wire.int.ent" apsTok - forM_ [tok1, tok2] $ \tk -> do + let tok2 = pushToken APNSVoIP "com.wire.dev.ent" apsTok + let tok3 = pushToken APNS "com.wire.int.ent" apsTok + forM_ [tok1, tok2, tok3] $ \tk -> do u1 <- randomUser u2 <- randomUser c1 <- randomClientId @@ -995,10 +952,6 @@ connectUsersAndDevicesWithSendingClientsRaw ca uidsAndConnIds = do assertPresences :: (UserId, [ConnId]) -> TestM () assertPresences (uid, conns) = wsAssertPresences uid (length conns) --- | Sort 'PushToken's based on the actual 'token' values. -sortPushTokens :: [PushToken] -> [PushToken] -sortPushTokens = sortBy (compare `on` view token) - wsRun :: HasCallStack => CannonR -> UserId -> ConnId -> WS.ClientApp () -> TestM (Async ()) wsRun ca uid (ConnId con) app = do liftIO $ async $ WS.runClientWith caHost caPort caPath caOpts caHdrs app diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs index 500ec668ff6..2e525f7cf1f 100644 --- a/services/gundeck/test/unit/Native.hs +++ b/services/gundeck/test/unit/Native.hs @@ -73,6 +73,8 @@ instance FromJSON SnsNotification where [("GCM", String n)] -> parseGcm n [("APNS", String n)] -> parseApns APNS n [("APNS_SANDBOX", String n)] -> parseApns APNSSandbox n + [("APNS_VOIP", String n)] -> parseApns APNSVoIP n + [("APNS_VOIP_SANDBOX", String n)] -> parseApns APNSVoIPSandbox n _ -> mempty where parseApns t n = From 44a66c58e0cfd2d7fda4d7c78a3b25fd20b7bb4c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 10 May 2024 13:39:42 +0200 Subject: [PATCH 16/30] [WPB-8628] Clean up syntax of test cases that occur in BSI audit. (#4041) Co-authored-by: Leif Battermann --- ...28-clean-up-syntax-of-tests-from-bsi-audit | 1 + integration/test/Test/AccessUpdate.hs | 3 - integration/test/Test/Login.hs | 9 - libs/zauth/test/ZAuth.hs | 5 +- .../brig/test/integration/API/User/Account.hs | 27 +- .../brig/test/integration/API/User/Auth.hs | 22 +- .../brig/test/integration/API/User/Client.hs | 86 ++---- .../brig/test/integration/API/User/Handles.hs | 5 +- .../integration/Test/Federator/IngressSpec.hs | 71 +++-- .../integration/Test/Federator/InwardSpec.hs | 44 ++- .../unit/Test/Federator/ExternalServer.hs | 6 +- .../unit/Test/Federator/InternalServer.hs | 5 +- .../test/unit/Test/Federator/Options.hs | 47 +-- .../test/unit/Test/Federator/Remote.hs | 5 +- .../test/unit/Test/Federator/Validation.hs | 15 +- services/galley/test/integration/API.hs | 58 +--- .../galley/test/integration/API/Federation.hs | 5 +- services/galley/test/integration/API/Teams.hs | 20 +- .../test-integration/Test/Spar/APISpec.hs | 274 +++++++++--------- .../Test/Spar/Scim/AuthSpec.hs | 16 +- .../Test/Spar/Scim/UserSpec.hs | 7 +- 21 files changed, 289 insertions(+), 442 deletions(-) create mode 100644 changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit diff --git a/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit b/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit new file mode 100644 index 00000000000..63c5cb9df02 --- /dev/null +++ b/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit @@ -0,0 +1 @@ +Clean up syntax of test cases that occur in BSI audit. \ No newline at end of file diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index 0152c6e63e6..1d9ad94ad23 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -38,7 +38,6 @@ testBaz :: HasCallStack => App () testBaz = pure () -} --- | @SF.Federation @SF.Separation @TSFI.RESTfulAPI @S2 -- -- The test asserts that, among others, remote users are removed from a -- conversation when an access update occurs that disallows guests from @@ -74,8 +73,6 @@ testAccessUpdateGuestRemoved = do res.status `shouldMatchInt` 200 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob --- @END - testAccessUpdateGuestRemovedUnreachableRemotes :: HasCallStack => App () testAccessUpdateGuestRemovedUnreachableRemotes = do resourcePool <- asks resourcePool diff --git a/integration/test/Test/Login.hs b/integration/test/Test/Login.hs index 1617e8b3a0f..b16f5ec3074 100644 --- a/integration/test/Test/Login.hs +++ b/integration/test/Test/Login.hs @@ -23,7 +23,6 @@ testLoginVerify6DigitEmailCodeSuccess = do bindResponse (loginWith2ndFactor owner email defPassword code) $ \resp -> do resp.status `shouldMatchInt` 200 --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login fails with wrong second factor email verification code testLoginVerify6DigitWrongCodeFails :: HasCallStack => App () @@ -39,9 +38,6 @@ testLoginVerify6DigitWrongCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login without verification code fails if SndFactorPasswordChallenge feature is enabled in team testLoginVerify6DigitMissingCodeFails :: HasCallStack => App () @@ -54,9 +50,6 @@ testLoginVerify6DigitMissingCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-required" --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login fails with expired second factor email verification code testLoginVerify6DigitExpiredCodeFails :: HasCallStack => App () @@ -80,8 +73,6 @@ testLoginVerify6DigitExpiredCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" --- @END - testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: HasCallStack => App () testLoginVerify6DigitResendCodeSuccessAndRateLimiting = do (owner, team, []) <- createTeam OwnDomain 0 diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 80545f884ae..db94845d04c 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -56,7 +56,7 @@ tests = do ], testGroup "Signing and Verifying" - [ testCase "expired" (runCreate z 1 $ testExpired v), + [ testCase "testExpired - expired" (runCreate z 1 $ testExpired v), testCase "not expired" (runCreate z 2 $ testNotExpired v), testCase "signed access-token is valid" (runCreate z 3 $ testSignAndVerify v) ], @@ -94,7 +94,6 @@ testNotExpired p = do liftIO $ assertBool "testNotExpired: validation failed" (isRight x) -- The testExpired test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 @S3 -- -- Using an expired access token should fail testExpired :: V.Env -> Create () @@ -105,8 +104,6 @@ testExpired p = do x <- liftIO $ runValidate p $ check t liftIO $ Left Expired @=? x --- @END - testSignAndVerify :: V.Env -> Create () testSignAndVerify p = do u <- liftIO nextRandom diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1ea564fcbb5..494ffecdc6e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -102,17 +102,17 @@ tests _ at opts p b c ch g aws userJournalWatcher = testGroup "account" [ test p "post /register - 201 (with preverified)" $ testCreateUserWithPreverified opts b userJournalWatcher, - test p "post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, + test p "testCreateUserWithInvalidVerificationCode - post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, test p "post /register - 201" $ testCreateUser b g, test p "post /register - 201 + no email" $ testCreateUserNoEmailNoPassword b, test p "post /register - 201 anonymous" $ testCreateUserAnon b g, - test p "post /register - 400 empty name" $ testCreateUserEmptyName b, - test p "post /register - 400 name too long" $ testCreateUserLongName b, + test p "testCreateUserEmptyName - post /register - 400 empty name" $ testCreateUserEmptyName b, + test p "testCreateUserLongName - post /register - 400 name too long" $ testCreateUserLongName b, test p "post /register - 201 anonymous expiry" $ testCreateUserAnonExpiry b, test p "post /register - 201 pending" $ testCreateUserPending opts b, test p "post /register - 201 existing activation" $ testCreateAccountPendingActivationKey opts b, - test p "post /register - 409 conflict" $ testCreateUserConflict opts b, - test p "post /register - 400 invalid input" $ testCreateUserInvalidEmailOrPhone opts b, + test p "testCreateUserConflict - post /register - 409 conflict" $ testCreateUserConflict opts b, + test p "testCreateUserInvalidEmailOrPhone - post /register - 400 invalid input" $ testCreateUserInvalidEmailOrPhone opts b, test p "post /register - 403 blacklist" $ testCreateUserBlacklist opts b aws, test p "post /register - 400 external-SSO" $ testCreateUserExternalSSO b, test p "post /register - 403 restricted user creation" $ testRestrictedUserCreation opts b, @@ -172,7 +172,6 @@ tests _ at opts p b c ch g aws userJournalWatcher = ] -- The testCreateUserWithInvalidVerificationCode test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Registering with an invalid verification code and valid account details should fail. testCreateUserWithInvalidVerificationCode :: Brig -> Http () @@ -197,8 +196,6 @@ testCreateUserWithInvalidVerificationCode brig = do ] postUserRegister' regEmail brig !!! const 404 === statusCode --- @END - testUpdateUserEmailByTeamOwner :: Opt.Opts -> Brig -> Http () testUpdateUserEmailByTeamOwner opts brig = do (_, teamOwner, emailOwner : otherTeamMember : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -336,7 +333,6 @@ assertOnlySelfConversations galley uid = do liftIO $ cnvType conv @?= SelfConv -- The testCreateUserEmptyName test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- An empty name is not allowed on registration testCreateUserEmptyName :: Brig -> Http () @@ -348,10 +344,7 @@ testCreateUserEmptyName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode --- @END - -- The testCreateUserLongName test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- a name with > 128 characters is not allowed. testCreateUserLongName :: Brig -> Http () @@ -364,8 +357,6 @@ testCreateUserLongName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode --- @END - testCreateUserAnon :: Brig -> Galley -> Http () testCreateUserAnon brig galley = do let p = @@ -443,7 +434,6 @@ testCreateUserNoEmailNoPassword brig = do !!! (const 202 === statusCode) -- The testCreateUserConflict test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- email address must not be taken on @/register@. testCreateUserConflict :: Opt.Opts -> Brig -> Http () @@ -475,10 +465,7 @@ testCreateUserConflict _ brig = do const 409 === statusCode const (Just "key-exists") === fmap Error.label . responseJsonMaybe --- @END - -- The testCreateUserInvalidEmailOrPhone test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Test to make sure a new user cannot be created with an invalid email address or invalid phone number. testCreateUserInvalidEmailOrPhone :: Opt.Opts -> Brig -> Http () @@ -508,8 +495,6 @@ testCreateUserInvalidEmailOrPhone _ brig = do post (brig . path "/register" . contentJson . body reqPhone) !!! const 400 === statusCode --- @END - testCreateUserBlacklist :: Opt.Opts -> Brig -> AWS.Env -> Http () testCreateUserBlacklist (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () testCreateUserBlacklist _ brig aws = @@ -893,7 +878,7 @@ testCreateUserAnonExpiry b = do let diff = diffUTCTime a now minExp = 1 :: Integer -- 1 second maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days - liftIO $ assertBool "expiry must in be the future" (diff >= fromIntegral minExp) + liftIO $ assertBool "expiry must be in the future" (diff >= fromIntegral minExp) liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) expire :: ResponseLBS -> Maybe UTCTime expire r = field "expires_at" =<< responseJsonMaybe r diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index a52cd738b41..8a23e8cbb27 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -100,9 +100,9 @@ tests conf m z db b g n = test m "handle" (testHandleLogin b), test m "email-untrusted-domain" (testLoginUntrustedDomain b), test m "send-phone-code" (testSendLoginCode b), - test m "failure" (testLoginFailure b), + test m "testLoginFailure - failure" (testLoginFailure b), test m "throttle" (testThrottleLogins conf b), - test m "limit-retry" (testLimitRetries conf b), + test m "testLimitRetries - limit-retry" (testLimitRetries conf b), test m "login with 6 character password" (testLoginWith6CharPassword b db), testGroup "sso-login" @@ -129,8 +129,8 @@ tests conf m z db b g n = ], testGroup "refresh /access" - [ test m "invalid-cookie" (testInvalidCookie @ZAuth.User z b), - test m "invalid-cookie legalhold" (testInvalidCookie @ZAuth.LegalHoldUser z b), + [ test m "testInvalidCookie - invalid-cookie" (testInvalidCookie @ZAuth.User z b), + test m "testInvalidCookie - invalid-cookie legalhold" (testInvalidCookie @ZAuth.LegalHoldUser z b), test m "invalid-token" (testInvalidToken z b), test m "missing-cookie" (testMissingCookie @ZAuth.User @ZAuth.Access z b), test m "missing-cookie legalhold" (testMissingCookie @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess z b), @@ -161,7 +161,7 @@ tests conf m z db b g n = [ test m "list" (testListCookies b), test m "remove-by-label" (testRemoveCookiesByLabel b), test m "remove-by-label-id" (testRemoveCookiesByLabelAndId b), - test m "limit" (testTooManyCookies conf b), + test m "testTooManyCookies - limit" (testTooManyCookies conf b), test m "logout" (testLogout b) ], testGroup @@ -423,7 +423,6 @@ testSendLoginCode brig = do liftIO $ assertEqual "timeout" (Just (Code.Timeout 600)) _timeout -- The testLoginFailure test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Test that trying to log in with a wrong password or non-existent email fails. testLoginFailure :: Brig -> Http () @@ -446,8 +445,6 @@ testLoginFailure brig = do PersistentCookie !!! const 403 === statusCode --- @END - testThrottleLogins :: Opts.Opts -> Brig -> Http () testThrottleLogins conf b = do -- Get the maximum amount of times we are allowed to login before @@ -473,7 +470,6 @@ testThrottleLogins conf b = do login b (defEmailLogin e) SessionCookie !!! const 200 === statusCode -- The testLimitRetries test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- The following test tests the login retries. It checks that a user can make -- only a prespecified number of attempts to log in with an invalid password, @@ -528,8 +524,6 @@ testLimitRetries conf brig = do liftIO $ threadDelay (1000000 * 2) login brig (defEmailLogin email) SessionCookie !!! const 200 === statusCode --- @END - ------------------------------------------------------------------------------- -- LegalHold Login @@ -656,7 +650,6 @@ testNoUserSsoLogin brig = do -- Token Refresh -- The testInvalidCookie test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- Test that invalid and expired tokens do not work. testInvalidCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () @@ -674,8 +667,6 @@ testInvalidCookie z b = do const 403 === statusCode const (Just "expired") =~= responseBody --- @END - testInvalidToken :: ZAuth.Env -> Brig -> Http () testInvalidToken z b = do user <- Public.userId <$> randomUser b @@ -1188,7 +1179,6 @@ testRemoveCookiesByLabelAndId b = do listCookies b (userId u) >>= liftIO . ([lbl] @=?) . map cookieLabel -- The testTooManyCookies test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test asserts that there is an upper limit for the number of user cookies -- per cookie type. It does that by concurrently attempting to create more @@ -1238,8 +1228,6 @@ testTooManyCookies config b = do ) xxx -> error ("Unexpected status code when logging in: " ++ show xxx) --- @END - testLogout :: Brig -> Http () testLogout b = do Just email <- userEmail <$> randomUser b diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 0fb44b9063f..b7bbd4c2cd1 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -108,27 +108,27 @@ tests _cl _at opts p db n b c g = testGroup "post /clients - verification code" [ test p "success" $ testAddGetClientVerificationCode db b g, - test p "missing code" $ testAddGetClientMissingCode b g, - test p "wrong code" $ testAddGetClientWrongCode b g, - test p "expired code" $ testAddGetClientCodeExpired db opts b g + test p "testAddGetClientMissingCode - missing code" $ testAddGetClientMissingCode b g, + test p "testAddGetClientWrongCode - wrong code" $ testAddGetClientWrongCode b g, + test p "testAddGetClientCodeExpired - expired code" $ testAddGetClientCodeExpired db opts b g ], test p "post /clients - 201 (with mls keys)" $ testAddGetClient def {addWithMLSKeys = True} b c, test p "post /clients - 403" $ testClientReauthentication b, test p "get /clients - 200" $ testListClients b, test p "get /clients/:client/prekeys - 200" $ testListPrekeyIds b, - test p "post /clients - 400" $ testTooManyClients opts b, - test p "client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b, - test p "lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b, - test p "lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b, - test p "delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c, - test p "delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c, - test p "delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b, - test p "delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b, + test p "testTooManyClients - post /clients - 400" $ testTooManyClients opts b, + test p "testPrekeysNotEmptyRandomPrekeys - client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b, + test p "testRegularPrekeysCannotBeSentAsLastPrekeys - lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b, + test p "testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate - lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b, + test p "testRemoveClient - delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c, + test p "testRemoveClient - delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c, + test p "testRemoveClientShortPwd - delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b, + test p "testRemoveClientIncorrectPwd - delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b, test p "put /clients/:client - 200" $ testUpdateClient opts b, test p "put /clients/:client - 200 (mls keys)" $ testMLSPublicKeyUpdate b, test p "get /clients/:client - 404" $ testMissingClient b, test p "get /clients/:client - 200" $ testMLSClient b, - test p "post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g c, + test p "testAddMultipleTemporary - post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g c, test p "client/prekeys/race" $ testPreKeyRace b, test p "get/head nonce/clients" $ testNewNonce b, testGroup @@ -161,7 +161,6 @@ testAddGetClientVerificationCode db brig galley = do const 200 === statusCode const (Just c) === responseJsonMaybe --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with missing second factor email verification code when this feature is enabled testAddGetClientMissingCode :: Brig -> Galley -> Http () @@ -178,9 +177,6 @@ testAddGetClientMissingCode brig galley = do const 403 === statusCode const (Just "code-authentication-required") === fmap Error.label . responseJsonMaybe --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with wrong second factor email verification code when this feature is enabled testAddGetClientWrongCode :: Brig -> Galley -> Http () @@ -198,9 +194,6 @@ testAddGetClientWrongCode brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with expired second factor email verification code when this feature is enabled testAddGetClientCodeExpired :: DB.ClientState -> Opt.Opts -> Brig -> Galley -> Http () @@ -225,8 +218,6 @@ testAddGetClientCodeExpired db opts brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe --- @END - data AddGetClient = AddGetClient { addWithPassword :: Bool, addWithMLSKeys :: Bool @@ -904,7 +895,6 @@ testMultiUserGetPrekeysQualifiedV4 brig opts = do const (Right $ expectedUserClientMap) === responseJsonEither -- The testTooManyClients test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test validates the upper bound on the number of permanent clients per -- user. It does so by trying to create one permanent client more than allowed. @@ -937,25 +927,25 @@ testPrekeysNotEmptyRandomPrekeys :: Opt.Opts -> Brig -> Http () testPrekeysNotEmptyRandomPrekeys opts brig = do -- Run the test for randomPrekeys (not dynamoDB locking) let newOpts = opts {Opt.randomPrekeys = Just True} - ensurePrekeysNotEmpty newOpts brig - -ensurePrekeysNotEmpty :: Opt.Opts -> Brig -> Http () -ensurePrekeysNotEmpty opts brig = withSettingsOverrides opts $ do - lgr <- Log.new Log.defSettings - uid <- userId <$> randomUser brig - -- Create a client with 1 regular prekey and 1 last resort prekey - c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10)) - -- Claim the first regular one - _rs1 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs2 - liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2 - liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again...")) - -- Claim again; this should (again) give the last resort one - rs3 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs3 - liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3 + ensurePrekeysNotEmpty newOpts + where + ensurePrekeysNotEmpty :: Opt.Opts -> Http () + ensurePrekeysNotEmpty newOpts = withSettingsOverrides newOpts $ do + lgr <- Log.new Log.defSettings + uid <- userId <$> randomUser brig + -- Create a client with 1 regular prekey and 1 last resort prekey + c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10)) + -- Claim the first regular one + _rs1 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs2 + liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2 + liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again...")) + -- Claim again; this should (again) give the last resort one + rs3 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs3 + liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3 testRegularPrekeysCannotBeSentAsLastPrekeys :: Brig -> Http () testRegularPrekeysCannotBeSentAsLastPrekeys brig = do @@ -985,10 +975,7 @@ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate brig = do !!! const 400 === statusCode --- @END - -- The testRemoveClient test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- This test validates creating and deleting a client. A client is created and -- consequently deleted. Deleting a second time yields response 404 not found. @@ -1034,10 +1021,7 @@ testRemoveClient hasPwd brig cannon = do newClientCookie = Just defCookieLabel } --- @END - -- The testRemoveClientShortPwd test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test checks if a client can be deleted by providing a too short password. -- This is done by using a single-character password, whereas the minimum is 6 @@ -1070,10 +1054,7 @@ testRemoveClientShortPwd brig = do newClientCookie = Just defCookieLabel } --- @END - -- The testRemoveClientIncorrectPwd test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test checks if a client can be deleted by providing a syntax-valid, but -- incorrect password. The client deletion attempt fails with a 403 error @@ -1106,8 +1087,6 @@ testRemoveClientIncorrectPwd brig = do newClientCookie = Just defCookieLabel } --- @END - testUpdateClient :: Opt.Opts -> Brig -> Http () testUpdateClient opts brig = do uid <- userId <$> randomUser brig @@ -1300,7 +1279,6 @@ testMissingClient brig = do . responseHeaders -- The testAddMultipleTemporary test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- Legacy (galley) -- -- Add temporary client, check that all services (both galley and @@ -1358,8 +1336,6 @@ testAddMultipleTemporary brig galley cannon = do . zUser u pure $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r) --- @END - testPreKeyRace :: Brig -> Http () testPreKeyRace brig = do uid <- userId <$> randomUser brig diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index d8bb4ac98ce..88164a3e600 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -56,7 +56,7 @@ tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon tests _cl _at conf p b c g = testGroup "handles" - [ test p "handles/update" $ testHandleUpdate b c, + [ test p "testHandleUpdate - handles/update" $ testHandleUpdate b c, test p "handles/race" $ testHandleRace b, test p "handles/query" $ testHandleQuery conf b, test p "handles/query - team-search-visibility SearchVisibilityStandard" $ testHandleQuerySearchVisibilityStandard conf b, @@ -69,7 +69,6 @@ tests _cl _at conf p b c g = ] -- The next line contains a mapping from the testHandleUpdate test to the following test standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test validates various updates to the user's handle. First, it attempts -- to set invalid handles. This fails. Then it successfully sets a valid handle. @@ -140,8 +139,6 @@ testHandleUpdate brig cannon = do put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! const 200 === statusCode --- @END - testHandleRace :: Brig -> Http () testHandleRace brig = do us <- replicateM 10 (userId <$> randomUser brig) diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 62b4f1b7401..f28fca1bdf1 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -73,45 +73,42 @@ spec env = do responseStatusCode resp `shouldBe` HTTP.status200 actualProfile `shouldBe` Just [expectedProfile] - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- This test was primarily intended to test that federator is using the API right (header - -- name etc.), but it is also effectively testing that federator rejects clients without - -- certificates that have been validated by ingress. - -- - -- We can't test end-to-end here: the TLS termination happens in k8s, and would have to be - -- tested there (and with a good emulation of the concrete configuration of the prod - -- system). - it "rejectRequestsWithoutClientCertIngress" $ - runTestFederator env $ do - brig <- view teBrig <$> ask - user <- randomUser brig - hdl <- randomHandle - _ <- putHandle brig (userId user) hdl + it "testRejectRequestsWithoutClientCertIngress" (testRejectRequestsWithoutClientCertIngress env) - settings <- view teSettings - sslCtxWithoutCert <- - either (throwM @_ @FederationSetupError) pure - <=< runM - . runEmbedded (liftIO @(TestFederator IO)) - . runError - $ mkSSLContextWithoutCert settings - runTestSem $ do - r <- - runError @RemoteError $ - inwardBrigCallViaIngressWithSettings - sslCtxWithoutCert - "get-user-by-handle" - (Aeson.fromEncoding (Aeson.toEncoding hdl)) - liftToCodensity . embed $ case r of - Right _ -> expectationFailure "Expected client certificate error, got response" - Left (RemoteError {}) -> - expectationFailure "Expected client certificate error, got remote error" - Left (RemoteErrorResponse _ _ status _) -> status `shouldBe` HTTP.status400 +-- +-- This test was primarily intended to test that federator is using the API right (header +-- name etc.), but it is also effectively testing that federator rejects clients without +-- certificates that have been validated by ingress. +-- +-- We can't test end-to-end here: the TLS termination happens in k8s, and would have to be +-- tested there (and with a good emulation of the concrete configuration of the prod +-- system). +testRejectRequestsWithoutClientCertIngress :: TestEnv -> IO () +testRejectRequestsWithoutClientCertIngress env = runTestFederator env $ do + brig <- view teBrig <$> ask + user <- randomUser brig + hdl <- randomHandle + _ <- putHandle brig (userId user) hdl --- FUTUREWORK: ORMOLU_DISABLE --- @END --- ORMOLU_ENABLE + settings <- view teSettings + sslCtxWithoutCert <- + either (throwM @_ @FederationSetupError) pure + <=< runM + . runEmbedded (liftIO @(TestFederator IO)) + . runError + $ mkSSLContextWithoutCert settings + runTestSem $ do + r <- + runError @RemoteError $ + inwardBrigCallViaIngressWithSettings + sslCtxWithoutCert + "get-user-by-handle" + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + liftToCodensity . embed $ case r of + Right _ -> expectationFailure "Expected client certificate error, got response" + Left (RemoteError {}) -> + expectationFailure "Expected client certificate error, got remote error" + Left (RemoteErrorResponse _ _ status _) -> status `shouldBe` HTTP.status400 liftToCodensity :: Member (Embed (Codensity IO)) r => Sem (Embed IO ': r) a -> Sem r a liftToCodensity = runEmbedded @IO @(Codensity IO) lift diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index 33cd7e89c92..85980f8948c 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -79,14 +79,7 @@ spec env = liftIO $ bdy `shouldBe` [expectedProfile] - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- This test is covered by the unit tests 'validateDomainCertWrongDomain' because - -- the domain matching is checked on certificate validation. - it "shouldRejectMissmatchingOriginDomainInward" $ - runTestFederator env $ - pure () - -- @END + it "testShouldRejectMissmatchingOriginDomainInward" (testShouldRejectMissmatchingOriginDomainInward env) it "should be able to call cargohold" $ runTestFederator env $ do @@ -117,23 +110,24 @@ spec env = inwardCall "/i/users" (encode o) !!! const 404 === statusCode - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- See related tests in unit tests (for matching client certificates against domain names) - -- and "IngressSpec". - it "rejectRequestsWithoutClientCertInward" $ - runTestFederator env $ do - originDomain <- originDomain <$> view teTstOpts - hdl <- randomHandle - inwardCallWithHeaders - "federation/brig/get-user-by-handle" - [(originDomainHeaderName, toByteString' originDomain)] - (encode hdl) - !!! const 400 === statusCode - --- TODO: ORMOLU_DISABLE --- @END --- ORMOLU_ENABLE + it "testRejectRequestsWithoutClientCertInward" (testRejectRequestsWithoutClientCertInward env) + +-- This test is covered by the unit tests 'validateDomainCertWrongDomain' because +-- the domain matching is checked on certificate validation. +testShouldRejectMissmatchingOriginDomainInward :: TestEnv -> IO () +testShouldRejectMissmatchingOriginDomainInward env = runTestFederator env $ pure () + +-- See related tests in unit tests (for matching client certificates against domain names) +-- and "IngressSpec". +testRejectRequestsWithoutClientCertInward :: TestEnv -> IO () +testRejectRequestsWithoutClientCertInward env = runTestFederator env $ do + originDomain <- originDomain <$> view teTstOpts + hdl <- randomHandle + inwardCallWithHeaders + "federation/brig/get-user-by-handle" + [(originDomainHeaderName, toByteString' originDomain)] + (encode hdl) + !!! const 400 === statusCode inwardCallWithHeaders :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index ec0b0438e24..7e499e3bc56 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -247,11 +247,9 @@ requestNoCertificate = assertEqual "no calls to any service should be made" [] serviceCalls pure Wai.ResponseReceived --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 --- Reject request if the client certificate for federator is invalid requestInvalidCertificate :: TestTree requestInvalidCertificate = - testCase "should fail with a 404 when an invalid certificate is given" $ do + testCase "testRequestInvalidCertificate - should fail with a 404 when an invalid certificate is given" $ do request <- testRequest def @@ -267,8 +265,6 @@ requestInvalidCertificate = assertEqual "no calls to any service should be made" [] serviceCalls pure Wai.ResponseReceived --- @END - testInvalidPaths :: TestTree testInvalidPaths = do let invalidPaths = diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 3fb41d2d869..86f9f7e93e7 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -107,12 +107,11 @@ federatedRequestSuccess = body <- Wai.lazyResponseBody res body @?= "\"bar\"" --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. federatedRequestFailureAllowList :: TestTree federatedRequestFailureAllowList = - testCase "should not make a call when target domain not in the allow list" $ do + testCase "federatedRequestFailureAllowList - should not make a call when target domain not in the allow list" $ do let settings = noClientCertSettings let targetDomain = Domain "target.example.com" headers = [(originDomainHeaderName, "origin.example.com")] @@ -150,5 +149,3 @@ federatedRequestFailureAllowList = . interpretMetricsEmpty $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) - --- @END diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 1530489e0f5..bece8365ab0 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -139,29 +139,7 @@ testSettings = <> show e Right _ -> assertFailure "expected failure for non-existing client certificate, got success", - -- @SF.Federation @TSFI.Federate @S3 @S7 - testCase "failToStartWithInvalidServerCredentials" $ do - let settings = - defRunSettings - "test/resources/unit/invalid.pem" - "test/resources/unit/localhost-key.pem" - assertParsesAs settings . B8.pack $ - [QQ.i| - useSystemCAStore: true - tcpConnectionTimeout: 1000 - federationStrategy: - allowAll: null - clientCertificate: test/resources/unit/invalid.pem - clientPrivateKey: test/resources/unit/localhost-key.pem|] - try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case - Left (InvalidClientCertificate _) -> pure () - Left e -> - assertFailure $ - "expected invalid client certificate exception, got: " - <> show e - Right _ -> - assertFailure "expected failure for invalid client certificate, got success", - -- @END + testCase "failToStartWithInvalidServerCredentials" failToStartWithInvalidServerCredentials, testCase "fail on invalid private key" $ do let settings = defRunSettings @@ -185,6 +163,29 @@ testSettings = assertFailure "expected failure for invalid private key, got success" ] +failToStartWithInvalidServerCredentials :: IO () +failToStartWithInvalidServerCredentials = do + let settings = + defRunSettings + "test/resources/unit/invalid.pem" + "test/resources/unit/localhost-key.pem" + assertParsesAs settings . B8.pack $ + [QQ.i| + useSystemCAStore: true + tcpConnectionTimeout: 1000 + federationStrategy: + allowAll: null + clientCertificate: test/resources/unit/invalid.pem + clientPrivateKey: test/resources/unit/localhost-key.pem|] + try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case + Left (InvalidClientCertificate _) -> pure () + Left e -> + assertFailure $ + "expected invalid client certificate exception, got: " + <> show e + Right _ -> + assertFailure "expected failure for invalid client certificate, got success" + assertParsesAs :: (HasCallStack, Eq a, FromJSON a, Show a) => a -> ByteString -> Assertion assertParsesAs v bs = assertEqual "YAML parsing" (Right v) $ diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 43be50b23d1..8d8de9f0660 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -129,7 +129,6 @@ testValidatesCertificateSuccess = Right _ -> assertFailure "Congratulations, you fixed a known issue!" ] --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 -- -- This is a group of test cases where refusing to connect with the server is -- checked. The second test case refuses to connect with a server when the @@ -138,7 +137,7 @@ testValidatesCertificateSuccess = testValidatesCertificateWrongHostname :: TestTree testValidatesCertificateWrongHostname = testGroup - "refuses to connect with server" + "testValidatesCertificateWrongHostname - refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ withMockServer certForWrongDomain $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings @@ -155,8 +154,6 @@ testValidatesCertificateWrongHostname = Right _ -> assertFailure "Expected connection with the server to fail" ] --- @END - testConnectionError :: TestTree testConnectionError = testCase "connection failures are reported correctly" $ do tlsSettings <- mkTLSSettingsOrThrow settings diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 4086567271b..24879f15aae 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -115,12 +115,11 @@ federateWithAllowListFail = $ ensureCanFederateWith (Domain "hello.world") assertBool "federating should not be allowed" (isLeft eith) --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. validateDomainAllowListFail :: TestTree validateDomainAllowListFail = - testCase "allow list validation" $ do + testCase "validateDomainAllowListFail - allow list validation" $ do Right exampleCert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" let settings = noClientCertSettings res <- @@ -133,8 +132,6 @@ validateDomainAllowListFail = $ validateDomain exampleCert (Domain "localhost.example.com") res @?= Left (FederationDenied (Domain "localhost.example.com")) --- @END - validateDomainAllowListSuccess :: TestTree validateDomainAllowListSuccess = testCase "should give parsed domain if in the allow list" $ do @@ -151,13 +148,12 @@ validateDomainAllowListSuccess = $ validateDomain exampleCert domain assertEqual "validateDomain should give 'localhost.example.com' as domain" domain res --- @SF.Federation @TSFI.Federate @TSFI.DNS @S3 @S7 -- -- Reject request if the infrastructure domain in the client cert does not match the backend -- domain in the `Wire-origin-domain` header. validateDomainCertWrongDomain :: TestTree validateDomainCertWrongDomain = - testCase "should fail if the client certificate has a wrong domain" $ do + testCase "validateDomainCertWrongDomain - should fail if the client certificate has a wrong domain" $ do Right exampleCert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" res <- runM @@ -169,8 +165,6 @@ validateDomainCertWrongDomain = $ validateDomain exampleCert (Domain "foo.example.com") res @?= Left (AuthenticationFailure (pure [X509.NameMismatch "foo.example.com"])) --- @END - validateDomainCertCN :: TestTree validateDomainCertCN = testCase "should succeed if the certificate has subject CN but no SAN" $ do @@ -253,12 +247,9 @@ validateDomainNonIdentitySRV = $ validateDomain exampleCert domain res @?= domain --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- Reject request if the client certificate for federator is invalid validateDomainCertInvalid :: TestTree validateDomainCertInvalid = - testCase "should fail if the client certificate is invalid" $ do + testCase "validateDomainCertInvalid - should fail if the client certificate is invalid" $ do let res = decodeCertificate "not a certificate" res @?= Left "no certificate found" - --- @END diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index fbf625a5138..b20fb577974 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -209,27 +209,27 @@ tests s = test s "conversation receipt mode update" putReceiptModeOk, test s "remote conversation receipt mode update" putRemoteReceiptModeOk, test s "leave connect conversation" leaveConnectConversation, - test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, - test s "post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson, - test s "post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto, + test s "postCryptoMessageVerifyMsgSentAndRejectIfMissingClient - post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, + test s "postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson - post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson, + test s "postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto - post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto, test s "post conversations/:cnv/otr/message: unknown sender client" postCryptoMessageNotAuthorizeUnknownClient, - test s "post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam, - test s "post message qualified - local owning backend - missing clients" postMessageQualifiedLocalOwningBackendMissingClients, + test s "postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam - post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam, + test s "postMessageQualifiedLocalOwningBackendMissingClients - post message qualified - local owning backend - missing clients" postMessageQualifiedLocalOwningBackendMissingClients, test s "post message qualified - local owning backend - redundant and deleted clients" postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients, - test s "post message qualified - local owning backend - ignore missing" postMessageQualifiedLocalOwningBackendIgnoreMissingClients, + test s "postMessageQualifiedLocalOwningBackendIgnoreMissingClients - post message qualified - local owning backend - ignore missing" postMessageQualifiedLocalOwningBackendIgnoreMissingClients, test s "post message qualified - local owning backend - failed to send clients" postMessageQualifiedLocalOwningBackendFailedToSendClients, test s "post message qualified - local owning backend - failed to fetch clients" postMessageQualifiedFailedToSendFetchingClients, test s "post message qualified - remote owning backend - federation failure" postMessageQualifiedRemoteOwningBackendFailure, test s "post message qualified - remote owning backend - success" postMessageQualifiedRemoteOwningBackendSuccess, test s "join conversation" postJoinConvOk, test s "get code-access conversation information" testJoinCodeConv, - test s "join code-access conversation - no password" postJoinCodeConvOk, + test s "postJoinCodeConvOk - join code-access conversation - no password" postJoinCodeConvOk, test s "join code-access conversation - password" postJoinCodeConvWithPassword, test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, test s "team member can't join via guest link if access role removed" testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved, test s "cannot join private conversation" postJoinConvFail, - test s "revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, + test s "testJoinTeamConvGuestLinksDisabled - revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, test s "revoke guest links for non-team conversation" testJoinNonTeamConvGuestLinksDisabled, test s "get code rejected if guest links disabled" testGetCodeRejectedIfGuestLinksDisabled, test s "post code rejected if guest links disabled" testPostCodeRejectedIfGuestLinksDisabled, @@ -242,8 +242,8 @@ tests s = ], test s "remove user with only local convs" removeUserNoFederation, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests, - test s "post message - reject if missing client" postMessageRejectIfMissingClients, - test s "post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg, + test s "postMessageRejectIfMissingClients - post message - reject if missing client" postMessageRejectIfMissingClients, + test s "postMessageClientNotInGroupDoesNotReceiveMsg - post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg, test s "get guest links status from foreign team conversation" getGuestLinksStatusFromForeignTeamConv, testGroup "Typing indicators" @@ -410,7 +410,6 @@ postConvWithUnreachableRemoteUsers rbs = do groupConvs WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies whether a message actually gets sent all the way to -- cannon. postCryptoMessageVerifyMsgSentAndRejectIfMissingClient :: TestM () @@ -499,12 +498,9 @@ postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do liftIO $ assertBool "unexpected equal clients" (bc /= bc2) assertNoMsg wsB2 (wsAssertOtr qconv qalice ac bc cipher) --- @END - --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behavior of the the JSON endpoint. -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson :: TestM () -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do (alice, ac) <- randomUserWithClient (head someLastPrekeys) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) @@ -527,12 +523,9 @@ postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- @END - --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behaviour of the protobuf endpoint. -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto :: TestM () -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto = do +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do (alice, ac) <- randomUserWithClient (head someLastPrekeys) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) @@ -557,8 +550,6 @@ postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- @END - -- | This test verifies behaviour when an unknown client posts the message. Only -- tests the Protobuf endpoint. postCryptoMessageNotAuthorizeUnknownClient :: TestM () @@ -574,7 +565,6 @@ postCryptoMessageNotAuthorizeUnknownClient = do postProtoOtrMessage alice (ClientId 0x172618352518396) conv m !!! const 403 === statusCode --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies the following scenario. -- A client sends a message to all clients of a group and one more who is not part of the group. -- The server must not send this message to client ids not part of the group. @@ -600,9 +590,6 @@ postMessageClientNotInGroupDoesNotReceiveMsg = do checkEveGetsMsg checkChadDoesNotGetMsg --- @END - --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies that when a client sends a message not to all clients of a group then the server should reject the message and sent a notification to the sender (412 Missing clients). -- The test is somewhat redundant because this is already tested as part of other tests already. This is a stand alone test that solely tests the behavior described above. postMessageRejectIfMissingClients :: TestM () @@ -630,9 +617,6 @@ postMessageRejectIfMissingClients = do mkMsg :: ByteString -> (UserId, ClientId) -> (UserId, ClientId, Text) mkMsg text (uid, clientId) = (uid, clientId, toBase64Text text) --- @END - --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies behaviour under various values of ignore_missing and -- report_missing. Only tests the JSON endpoint. postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam :: TestM () @@ -690,9 +674,6 @@ postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam = do where listToByteString = BS.intercalate "," . map toByteString' --- @END - --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will not be sent. @@ -753,8 +734,6 @@ postMessageQualifiedLocalOwningBackendMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] --- @END - -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message, it is expected that message will -- be sent successfully. @@ -845,7 +824,6 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- Wait less for no message WS.assertNoEvent (1 # Second) [wsNonMember] --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will be sent except when it is specifically @@ -972,8 +950,6 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] --- @END - postMessageQualifiedLocalOwningBackendFailedToSendClients :: TestM () postMessageQualifiedLocalOwningBackendFailedToSendClients = do -- WS receive timeout @@ -1203,7 +1179,6 @@ testPostCodeRejectedIfGuestLinksDisabled = do setStatus Public.FeatureStatusEnabled checkPostCode 200 --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Check if guests cannot join anymore if guest invite feature was disabled on team level testJoinTeamConvGuestLinksDisabled :: TestM () testJoinTeamConvGuestLinksDisabled = do @@ -1261,8 +1236,6 @@ testJoinTeamConvGuestLinksDisabled = do postJoinCodeConv bob' cCode !!! const 200 === statusCode checkFeatureStatus Public.FeatureStatusEnabled --- @END - testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do let convName = "testConversation" @@ -1286,7 +1259,6 @@ testJoinNonTeamConvGuestLinksDisabled = do const (Right (ConversationCoverView convId (Just convName) False)) === responseJsonEither const 200 === statusCode --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test case covers a negative check that if access code of a guest link is revoked no further -- people can join the group conversation. Additionally it covers: -- Random users can use invite link @@ -1341,8 +1313,6 @@ postJoinCodeConvOk = do putQualifiedAccessUpdate alice qconv noCodeAccess !!! const 200 === statusCode postJoinCodeConv dave payload !!! const 404 === statusCode --- @END - postJoinCodeConvWithPassword :: TestM () postJoinCodeConvWithPassword = do alice <- randomUser diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index e6bd8eea883..abd5bfccac8 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -69,7 +69,7 @@ tests s = testGroup "federation" [ test s "POST /federation/get-conversations : All Found" getConversationsAllFound, - test s "POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, + test s "getConversationsNotPartOf - POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, test s "POST /federation/on-conversation-created : Add local user to remote conversation" onConvCreated, test s "POST /federation/on-conversation-updated : Add local user to remote conversation" addLocalUser, test s "POST /federation/on-conversation-updated : Add only unconnected local users to remote conversation" addUnconnectedUsersOnly, @@ -159,7 +159,6 @@ getConversationsAllFound = do (Just (sort [bob, qUnqualified carlQ])) (fmap (sort . map (qUnqualified . omQualifiedId) . (.members.others)) c2) --- @SF.Federation @TSFI.RESTfulAPI @S2 -- -- The test asserts that via a federation client a user cannot fetch -- conversation details of a conversation they are not part of: they get an @@ -188,8 +187,6 @@ getConversationsNotPartOf = do GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs --- @END - onConvCreated :: TestM () onConvCreated = do c <- view tsCannon diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index dc5fffe2731..060116473e0 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -144,14 +144,14 @@ tests s = testGroup "delete team - verification code" [ test s "success" testDeleteTeamVerificationCodeSuccess, - test s "wrong code" testDeleteTeamVerificationCodeWrongCode, - test s "missing code" testDeleteTeamVerificationCodeMissingCode, - test s "expired code" testDeleteTeamVerificationCodeExpiredCode + test s "testDeleteTeamVerificationCodeWrongCode - wrong code" testDeleteTeamVerificationCodeWrongCode, + test s "testDeleteTeamVerificationCodeMissingCode - missing code" testDeleteTeamVerificationCodeMissingCode, + test s "testDeleteTeamVerificationCodeExpiredCode - expired code" testDeleteTeamVerificationCodeExpiredCode ], test s "delete team conversation" testDeleteTeamConv, test s "update team data" testUpdateTeam, test s "update team data icon validation" testUpdateTeamIconValidation, - test s "update team member" testUpdateTeamMember, + test s "testUpdateTeamMember - update team member" testUpdateTeamMember, test s "update team status" testUpdateTeamStatus, test s "send billing events to owners even in large teams" testBillingInLargeTeam, testGroup "broadcast" $ @@ -1044,7 +1044,6 @@ testDeleteTeamVerificationCodeSuccess = do const 202 === statusCode assertTeamDelete 10 "team delete, should be there" tid --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with missing second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeMissingCode :: TestM () @@ -1066,9 +1065,6 @@ testDeleteTeamVerificationCodeMissingCode = do const 403 === statusCode const "code-authentication-required" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with expired second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeExpiredCode :: TestM () @@ -1093,9 +1089,6 @@ testDeleteTeamVerificationCodeExpiredCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END - --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with wrong second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeWrongCode :: TestM () @@ -1118,8 +1111,6 @@ testDeleteTeamVerificationCodeWrongCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END - setFeatureLockStatus :: forall cfg. (KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> Public.LockStatus -> TestM () setFeatureLockStatus tid status = do g <- viewGalley @@ -1397,7 +1388,6 @@ testBillingInLargeTeam = do assertTeamUpdate ("delete fanoutLimit + 3rd billing member: " <> show ownerFanoutPlusThree) team (fanoutLimit + 2) (allOwnersBeforeFanoutLimit <> [ownerFanoutPlusTwo]) refreshIndex --- | @SF.Management @TSFI.RESTfulAPI @S2 -- This test covers: -- Promotion, demotion of team roles. -- Demotion by superior roles is allowed. @@ -1464,8 +1454,6 @@ testUpdateTeamMember = do e ^. eventTeam @?= tid e ^. eventData @?= EdMemberUpdate uid mPerm --- @END - testUpdateTeamStatus :: TestM () testUpdateTeamStatus = do g <- viewGalley diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 52d502da6fc..ea777758532 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -214,30 +214,9 @@ specInitiateLogin = do specFinalizeLogin :: SpecWith TestEnv specFinalizeLogin = do describe "POST /sso/finalize-login" $ do - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Send authentication error and no cookie if response from SSO IdP was rejected - context "rejectsSAMLResponseSayingAccessNotGranted" $ do - it "responds with a very peculiar 'forbidden' HTTP response" $ do - (user, tid) <- callCreateUserWithTeam - (idp, (_, privcreds)) <- registerTestIdPWithMeta user - authnreq <- negotiateAuthnRequest idp - spmeta <- getTestSPMetadata tid - authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False - sparresp <- submitAuthnResponse tid authnresp - liftIO $ do - statusCode sparresp `shouldBe` 200 - let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) - bdy `shouldContain` "" - bdy `shouldContain` "" - bdy `shouldContain` "wire:sso:error:forbidden" - bdy `shouldContain` "window.opener.postMessage({" - bdy `shouldContain` "\"type\":\"AUTH_ERROR\"" - bdy `shouldContain` "\"payload\":{" - bdy `shouldContain` "\"label\":\"forbidden\"" - bdy `shouldContain` "}, receiverOrigin)" - hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" - - -- @END + context "not granted" $ do + it "testRejectsSAMLResponseSayingAccessNotGranted - responds with a very peculiar 'forbidden' HTTP response" $ + testRejectsSAMLResponseSayingAccessNotGranted context "access granted" $ do let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () @@ -314,7 +293,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp3 spmeta authnreq True loginSuccess =<< submitAuthnResponse tid3 authnresp - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 -- Do not authenticate if SSO IdP response is for different team context "rejectsSAMLResponseInWrongTeam" $ do it "fails" $ do @@ -341,8 +319,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp2 spmeta authnreq True loginFailure =<< submitAuthnResponse tid2 authnresp - -- @END - context "user is created once, then deleted in team settings, then can login again." $ do it "responds with 'allowed'" $ do (ownerid, teamid) <- callCreateUserWithTeam @@ -406,115 +382,10 @@ specFinalizeLogin = do pending context "bad AuthnResponse" $ do - let check :: - (IdP -> TestSpar SAML.AuthnRequest) -> - (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) -> - (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) -> - (ResponseLBS -> IO ()) -> - TestSpar () - check mkareq mkaresp submitaresp checkresp = do - (ownerid, teamid) <- callCreateUserWithTeam - (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid - authnreq <- mkareq idp - spmeta <- getTestSPMetadata teamid - authnresp <- - runSimpleSP $ - mkaresp - privcreds - idp - spmeta - authnreq - sparresp <- submitaresp teamid authnresp - liftIO $ checkresp sparresp - - shouldContainInBase64 :: String -> String -> Expectation - shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle - where - Right (Just hay'') = decodeBase64 <$> validateBase64 hay' - hay' = cs $ f hay - where - -- exercise to the reader: do this more idiomatically! - f (splitAt 5 -> ("
", s)) = g s
-                  f (_ : s) = f s
-                  f "" = ""
-                  g (splitAt 6 -> ("
", _)) = "" - g (c : s) = c : g s - g "" = "" - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is for unknown issuer - it "rejectsSAMLResponseFromWrongIssuer" $ do - let mkareq = negotiateAuthnRequest - mkaresp privcreds idp spmeta authnreq = - mkAuthnResponse - privcreds - (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) - spmeta - authnreq - True - submitaresp = submitAuthnResponse - checkresp sparresp = do - statusCode sparresp `shouldBe` 404 - -- body should contain the error label in the title, the verbatim haskell error, and the request: - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is signed with wrong key - it "rejectsSAMLResponseSignedWithWrongKey" $ do - (ownerid, _teamid) <- callCreateUserWithTeam - (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid - let mkareq = negotiateAuthnRequest - mkaresp _ idp spmeta authnreq = - mkAuthnResponse - badprivcreds - idp - spmeta - authnreq - True - submitaresp = submitAuthnResponse - checkresp sparresp = statusCode sparresp `shouldBe` 400 - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response has no corresponding request anymore - it "rejectsSAMLResponseIfRequestIsStale" $ do - let mkareq idp = do - req <- negotiateAuthnRequest idp - runSpar $ AReqIDStore.unStore (req ^. SAML.rqID) - pure req - mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True - submitaresp = submitAuthnResponse - checkresp sparresp = do - statusCode sparresp `shouldBe` 200 - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" - (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is gone missing - it "rejectsSAMLResponseIfResponseIsStale" $ do - let mkareq = negotiateAuthnRequest - mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True - submitaresp teamid authnresp = do - _ <- submitAuthnResponse teamid authnresp - submitAuthnResponse teamid authnresp - checkresp sparresp = do - statusCode sparresp `shouldBe` 200 - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" - check mkareq mkaresp submitaresp checkresp - - -- {- ORMOLU_DISABLE -} -- FUTUREWORK: try a newer release of ormolu? - -- @END - -- {- ORMOLU_ENABLE -} + it "testRejectsSAMLResponseFromWrongIssuer" testRejectsSAMLResponseFromWrongIssuer + it "testRejectsSAMLResponseSignedWithWrongKey" testRejectsSAMLResponseSignedWithWrongKey + it "testRejectsSAMLResponseIfRequestIsStale" testRejectsSAMLResponseIfRequestIsStale + it "testRejectsSAMLResponseIfResponseIsStale" testRejectsSAMLResponseIfResponseIsStale context "IdP changes response format" $ do it "treats NameId case-insensitively" $ do @@ -1787,3 +1658,134 @@ specReAuthSsoUserWithPassword = payload = RequestBodyLBS . encode . object . maybeToList $ fmap ("password" .=) pw + +---------------------------------------------------------------------- +-- tests for bsi audit + +testRejectsSAMLResponseSayingAccessNotGranted :: TestSpar () +testRejectsSAMLResponseSayingAccessNotGranted = do + (user, tid) <- callCreateUserWithTeam + (idp, (_, privcreds)) <- registerTestIdPWithMeta user + authnreq <- negotiateAuthnRequest idp + spmeta <- getTestSPMetadata tid + authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False + sparresp <- submitAuthnResponse tid authnresp + liftIO $ do + statusCode sparresp `shouldBe` 200 + let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) + bdy `shouldContain` "" + bdy `shouldContain` "" + bdy `shouldContain` "wire:sso:error:forbidden" + bdy `shouldContain` "window.opener.postMessage({" + bdy `shouldContain` "\"type\":\"AUTH_ERROR\"" + bdy `shouldContain` "\"payload\":{" + bdy `shouldContain` "\"label\":\"forbidden\"" + bdy `shouldContain` "}, receiverOrigin)" + hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" + +-- Do not authenticate if SSO IdP response is for unknown issuer +testRejectsSAMLResponseFromWrongIssuer :: TestSpar () +testRejectsSAMLResponseFromWrongIssuer = do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = + mkAuthnResponse + privcreds + (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 404 + -- body should contain the error label in the title, the verbatim haskell error, and the request: + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" + checkSamlFlow + mkareq + mkaresp + submitaresp + checkresp + +-- Do not authenticate if SSO IdP response is signed with wrong key +testRejectsSAMLResponseSignedWithWrongKey :: TestSpar () +testRejectsSAMLResponseSignedWithWrongKey = do + (ownerid, _teamid) <- callCreateUserWithTeam + (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid + let mkareq = negotiateAuthnRequest + mkaresp _ idp spmeta authnreq = + mkAuthnResponse + badprivcreds + idp + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = statusCode sparresp `shouldBe` 400 + checkSamlFlow mkareq mkaresp submitaresp checkresp + +-- Do not authenticate if SSO IdP response has no corresponding request anymore +testRejectsSAMLResponseIfRequestIsStale :: TestSpar () +testRejectsSAMLResponseIfRequestIsStale = do + let mkareq idp = do + req <- negotiateAuthnRequest idp + runSpar $ AReqIDStore.unStore (req ^. SAML.rqID) + pure req + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" + checkSamlFlow mkareq mkaresp submitaresp checkresp + +-- Do not authenticate if SSO IdP response is gone missing +testRejectsSAMLResponseIfResponseIsStale :: TestSpar () +testRejectsSAMLResponseIfResponseIsStale = do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp teamid authnresp = do + _ <- submitAuthnResponse teamid authnresp + submitAuthnResponse teamid authnresp + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + checkSamlFlow mkareq mkaresp submitaresp checkresp + +---------------------------------------------------------------------- +-- Helpers + +shouldContainInBase64 :: String -> String -> Expectation +shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle + where + Right (Just hay'') = decodeBase64 <$> validateBase64 hay' + hay' = cs $ f hay + where + -- exercise to the reader: do this more idiomatically! + f (splitAt 5 -> ("
", s)) = g s
+        f (_ : s) = f s
+        f "" = ""
+        g (splitAt 6 -> ("
", _)) = "" + g (c : s) = c : g s + g "" = "" + +checkSamlFlow :: + (IdP -> TestSpar SAML.AuthnRequest) -> + (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) -> + (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) -> + (ResponseLBS -> IO ()) -> + TestSpar () +checkSamlFlow mkareq mkaresp submitaresp checkresp = do + (ownerid, teamid) <- callCreateUserWithTeam + (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid + authnreq <- mkareq idp + spmeta <- getTestSPMetadata teamid + authnresp <- + runSimpleSP $ + mkaresp + privcreds + idp + spmeta + authnreq + sparresp <- submitaresp teamid authnresp + liftIO $ checkresp sparresp diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index e646e8e2a57..9247594fe87 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -63,7 +63,7 @@ spec = do specDeleteToken specListTokens describe "Miscellaneous" $ do - it "doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded + it "testAuthIsNeeded - doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded ---------------------------------------------------------------------------- -- Token creation @@ -74,9 +74,9 @@ specCreateToken = describe "POST /auth-tokens" $ do it "works" testCreateToken it "respects the token limit" testTokenLimit it "requires the team to have no more than one IdP" testNumIdPs - it "authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins + it "testCreateTokenAuthorizesOnlyAdmins - authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins it "requires a password" testCreateTokenRequiresPassword - it "works with verification code" testCreateTokenWithVerificationCode + it "testCreateTokenWithVerificationCode - works with verification code" testCreateTokenWithVerificationCode -- FUTUREWORK: we should also test that for a password-less user, e.g. for an SSO user, -- reauthentication is not required. We currently (2019-03-05) can't test that because @@ -106,8 +106,6 @@ testCreateToken = do listUsers_ (Just token) (Just fltr) (env ^. teSpar) !!! const 200 === statusCode --- @SF.Channel @TSFI.RESTfulAPI @S2 --- -- Test positive case but also that a SCIM token cannot be created with wrong -- or missing second factor email verification code when this feature is enabled testCreateTokenWithVerificationCode :: TestSpar () @@ -143,8 +141,6 @@ testCreateTokenWithVerificationCode = do call $ post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email)) --- @END - unlockFeature :: GalleyReq -> TeamId -> TestSpar () unlockFeature galley tid = call $ put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig, toByteString' Public.LockStatusUnlocked]) !!! const 200 === statusCode @@ -223,7 +219,6 @@ testNumIdPs = do createToken_ owner (CreateScimToken "drei" (Just defPassword) Nothing) (env ^. teSpar) !!! checkErr 400 (Just "more-than-one-idp") --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- Test that a token can only be created as a team owner testCreateTokenAuthorizesOnlyAdmins :: TestSpar () testCreateTokenAuthorizesOnlyAdmins = do @@ -256,8 +251,6 @@ testCreateTokenAuthorizesOnlyAdmins = do (mkUser RoleAdmin >>= createToken') !!! const 200 === statusCode --- @END - -- | Test that for a user with a password, token creation requires reauthentication (i.e. the -- field @"password"@ should be provided). -- @@ -456,7 +449,6 @@ testDeletedTokensAreUnlistable = do ---------------------------------------------------------------------------- -- Miscellaneous tests --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- This test verifies that the SCIM API responds with an authentication error -- and can't be used if it receives an invalid secret token -- or if no token is provided at all @@ -468,5 +460,3 @@ testAuthIsNeeded = do listUsers_ (Just invalidToken) Nothing (env ^. teSpar) !!! checkErr 401 Nothing -- Try to do @GET /Users@ without a token and check that it fails listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing - --- @END diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 5d23f93a9be..1ff2bdb2584 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -490,7 +490,7 @@ specCreateUser = describe "POST /Users" $ do it "set locale to hr and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage (Just (Locale (Language HR) Nothing)) Nothing it "set locale to default and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage Nothing Nothing it "requires externalId to be present" $ testExternalIdIsRequired - it "rejects invalid handle" $ testCreateRejectsInvalidHandle + it "testCreateRejectsInvalidHandle - rejects invalid handle" $ testCreateRejectsInvalidHandle it "rejects occupied handle" $ testCreateRejectsTakenHandle it "rejects occupied externalId (uref)" $ testCreateRejectsTakenExternalId True it "rejects occupied externalId (email)" $ testCreateRejectsTakenExternalId False @@ -840,9 +840,6 @@ testExternalIdIsRequired = do createUser_ (Just tok) user' (env ^. teSpar) !!! const 400 === statusCode --- The next line contains a mapping from this test to the following test standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 --- -- Test that user creation fails if handle is invalid testCreateRejectsInvalidHandle :: TestSpar () testCreateRejectsInvalidHandle = do @@ -853,8 +850,6 @@ testCreateRejectsInvalidHandle = do createUser_ (Just tok) (user {Scim.User.userName = "#invalid name"}) (env ^. teSpar) !!! const 400 === statusCode --- @END - -- | Test that user creation fails if handle is already in use (even on different team). testCreateRejectsTakenHandle :: TestSpar () testCreateRejectsTakenHandle = do From 0265f3487f5c75deaac90ed09737d1d1ccd655ab Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 13 May 2024 10:15:34 +0200 Subject: [PATCH 17/30] Add assertions to MLS one-to-one test (#4047) Check that the backend has an up-to-date view of the ciphersuite of a one-to-one conversation after the first commit. --- integration/test/Test/MLS/One2One.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index 2598c10ad5b..c8b5e4deedb 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -22,6 +22,8 @@ import API.Galley import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Read as T import MLS.Util import Notifications import SetupHelpers @@ -257,3 +259,11 @@ testMLSOne2One suite scenario = do let isMessage n = nPayload n %. "type" `isEqual` "conversation.mls-message-add" n <- awaitMatch isMessage ws nPayload n %. "data" `shouldMatch` B8.unpack (Base64.encode mp.message) + + -- Send another commit. This verifies that the backend has correctly updated + -- the cipersuite of this conversation. + void $ createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle + + conv' <- getMLSOne2OneConversation alice bob >>= getJSON 200 + (suiteCode, _) <- assertOne $ T.hexadecimal (T.pack suite.code) + conv' %. "cipher_suite" `shouldMatchInt` suiteCode From 142299c43df773b661b977925a1b1a2aebd28138 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 13 May 2024 14:16:27 +0200 Subject: [PATCH 18/30] gundeck: Delete all APNS_VOIP and APNS_VOIP_SANDBOX push tokens (#4044) * gundeck: Introduce data migrations First one will delete any VOIP push tokens * nix: Add gundeck-migrate-data image * charts/cassandra-migrations: Run gundeck-migrate-data * changelog * format * charts/cassandra-migrations: Add missing image name for gundeckMigrateData * [gundeck] fixed reference to galley test * [gundeck] Added missing data_migration table. * cassandra-schema.cql: updated. --------- Co-authored-by: Igor Ranieri --- cassandra-schema.cql | 52 +++++--- changelog.d/2-features/delete-voip-tokens | 1 + .../templates/galley-migrate-data.yaml | 1 - .../templates/gundeck-migrate-data.yaml | 59 +++++++++ charts/cassandra-migrations/values.yaml | 1 + nix/wire-server.nix | 2 +- services/gundeck/default.nix | 4 + services/gundeck/gundeck.cabal | 92 ++++++++++++-- services/gundeck/migrate-data/main.hs | 1 + .../migrate-data/src/Gundeck/DataMigration.hs | 120 ++++++++++++++++++ .../src/Gundeck/DataMigration/Types.hs | 78 ++++++++++++ services/gundeck/migrate-data/src/Run.hs | 32 +++++ .../src/V1_DeleteApnsVoipTokens.hs | 90 +++++++++++++ services/gundeck/src/Gundeck/Schema/Run.hs | 4 +- services/gundeck/src/Gundeck/Schema/V11.hs | 35 +++++ 15 files changed, 546 insertions(+), 26 deletions(-) create mode 100644 changelog.d/2-features/delete-voip-tokens create mode 100644 charts/cassandra-migrations/templates/gundeck-migrate-data.yaml create mode 100644 services/gundeck/migrate-data/main.hs create mode 100644 services/gundeck/migrate-data/src/Gundeck/DataMigration.hs create mode 100644 services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs create mode 100644 services/gundeck/migrate-data/src/Run.hs create mode 100644 services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs create mode 100644 services/gundeck/src/Gundeck/Schema/V11.hs diff --git a/cassandra-schema.cql b/cassandra-schema.cql index a35870fedfd..06052e52b77 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1720,19 +1720,17 @@ CREATE TABLE galley_test.mls_proposal_refs ( AND speculative_retry = '99PERCENTILE'; CREATE KEYSPACE gundeck_test WITH replication = {'class': 'SimpleStrategy', 'replication_factor': '1'} AND durable_writes = true; -CREATE TABLE gundeck_test.push ( - ptoken text, - app text, - transport int, - client text, - connection blob, - usr uuid, - PRIMARY KEY (ptoken, app, transport) -) WITH CLUSTERING ORDER BY (app ASC, transport ASC) - AND bloom_filter_fp_chance = 0.1 +CREATE TABLE gundeck_test.data_migration ( + id int, + version int, + date timestamp, + descr text, + PRIMARY KEY (id, version) +) WITH CLUSTERING ORDER BY (version ASC) + AND bloom_filter_fp_chance = 0.01 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} AND comment = '' - AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} 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 @@ -1790,10 +1788,16 @@ CREATE TABLE gundeck_test.meta ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; -CREATE TABLE gundeck_test.notification_payload ( - id uuid PRIMARY KEY, - payload blob -) WITH bloom_filter_fp_chance = 0.1 +CREATE TABLE gundeck_test.push ( + ptoken text, + app text, + transport int, + client text, + connection blob, + usr uuid, + PRIMARY KEY (ptoken, app, transport) +) WITH CLUSTERING ORDER BY (app ASC, transport ASC) + AND 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'} @@ -1832,6 +1836,24 @@ CREATE TABLE gundeck_test.user_push ( AND min_index_interval = 128 AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; + +CREATE TABLE gundeck_test.notification_payload ( + id uuid PRIMARY KEY, + payload blob +) 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 KEYSPACE spar_test WITH replication = {'class': 'SimpleStrategy', 'replication_factor': '1'} AND durable_writes = true; CREATE TABLE spar_test.bind_cookie ( diff --git a/changelog.d/2-features/delete-voip-tokens b/changelog.d/2-features/delete-voip-tokens new file mode 100644 index 00000000000..3014514221c --- /dev/null +++ b/changelog.d/2-features/delete-voip-tokens @@ -0,0 +1 @@ +gundeck: Delete all APNS_VOIP and APNS_VOIP_SANDBOX push tokens diff --git a/charts/cassandra-migrations/templates/galley-migrate-data.yaml b/charts/cassandra-migrations/templates/galley-migrate-data.yaml index 127a6ab0b54..768f5a94326 100644 --- a/charts/cassandra-migrations/templates/galley-migrate-data.yaml +++ b/charts/cassandra-migrations/templates/galley-migrate-data.yaml @@ -20,7 +20,6 @@ spec: metadata: name: "{{.Release.Name}}" labels: - app: galley-migrate-data app: galley-migrate-data heritage: {{.Release.Service | quote }} release: {{.Release.Name | quote }} diff --git a/charts/cassandra-migrations/templates/gundeck-migrate-data.yaml b/charts/cassandra-migrations/templates/gundeck-migrate-data.yaml new file mode 100644 index 00000000000..159fdfbcfd2 --- /dev/null +++ b/charts/cassandra-migrations/templates/gundeck-migrate-data.yaml @@ -0,0 +1,59 @@ +# This jobs runs migrations on the gundeck DB using the gundeck-migrate-data tool. +# The source for the tool can be found at services/gundeck in the wire-server +# repository. +{{- if .Values.enableGundeckMigrations }} +apiVersion: batch/v1 +kind: Job +metadata: + name: gundeck-migrate-data + labels: + app: "cassandra-migrations" + chart: "{{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" + annotations: + "helm.sh/hook": post-install,post-upgrade + "helm.sh/hook-weight": "10" + "helm.sh/hook-delete-policy": "before-hook-creation" +spec: + template: + metadata: + name: "{{.Release.Name}}" + labels: + app: gundeck-migrate-data + heritage: {{.Release.Service | quote }} + release: {{.Release.Name | quote }} + chart: "{{.Chart.Name}}-{{.Chart.Version}}" + spec: + restartPolicy: OnFailure + containers: + - name: gundeck-migrate-data + image: "{{ .Values.images.gundeckMigrateData }}:{{ .Values.images.tag }}" + imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} + {{- if eq (include "includeSecurityContext" .) "true" }} + securityContext: + {{- toYaml .Values.podSecurityContext | nindent 12 }} + {{- end }} + args: + - --cassandra-host + - "{{ template "cassandraGundeckHost" . }}" + - --cassandra-port + - "9042" + - --cassandra-keyspace + - gundeck + {{- if eq (include "useTlsGundeck" .) "true" }} + - --tls-ca-certificate-file + - /certs/gundeck/{{- (include "tlsSecretRefGundeck" . | fromYaml).key }} + {{- end }} + {{- if eq (include "useTlsGundeck" .) "true" }} + volumeMounts: + - name: gundeck-cassandra-cert + mountPath: "/certs/gundeck" + {{- end }} + {{- if eq (include "useTlsGundeck" .) "true" }} + volumes: + - name: gundeck-cassandra-cert + secret: + secretName: {{ (include "tlsSecretRefGundeck" . | fromYaml).name }} + {{- end }} +{{- end }} diff --git a/charts/cassandra-migrations/values.yaml b/charts/cassandra-migrations/values.yaml index 283a010884f..a66fc6bc231 100644 --- a/charts/cassandra-migrations/values.yaml +++ b/charts/cassandra-migrations/values.yaml @@ -5,6 +5,7 @@ images: galley: quay.io/wire/galley-schema spar: quay.io/wire/spar-schema galleyMigrateData: quay.io/wire/galley-migrate-data + gundeckMigrateData: quay.io/wire/gundeck-migrate-data sparMigrateData: quay.io/wire/spar-migrate-data # Setting cassandra host name and replication is mandatory to specify. diff --git a/nix/wire-server.nix b/nix/wire-server.nix index 9815de26869..eca106680b7 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -76,7 +76,7 @@ let cargohold = [ "cargohold" "cargohold-integration" ]; federator = [ "federator" "federator-integration" ]; galley = [ "galley" "galley-integration" "galley-schema" "galley-migrate-data" ]; - gundeck = [ "gundeck" "gundeck-integration" "gundeck-schema" ]; + gundeck = [ "gundeck" "gundeck-integration" "gundeck-schema" "gundeck-migrate-data" ]; proxy = [ "proxy" ]; spar = [ "spar" "spar-integration" "spar-schema" "spar-migrate-data" ]; stern = [ "stern" "stern-integration" ]; diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index a1c3759ede2..3614f31e11b 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -18,6 +18,7 @@ , bytestring , bytestring-conversion , cassandra-util +, conduit , containers , criterion , errors @@ -153,8 +154,10 @@ mkDerivation { bytestring bytestring-conversion cassandra-util + conduit containers exceptions + extended gundeck-types HsOpenSSL http-client @@ -175,6 +178,7 @@ mkDerivation { tasty-ant-xml tasty-hunit text + time tinylog types-common uuid diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 45b786e9ca2..52532c525ad 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 name: gundeck version: 1.45.0 synopsis: Push Notification Hub @@ -6,7 +6,7 @@ category: Network author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 +license: AGPL-3.0-only license-file: LICENSE build-type: Simple @@ -46,6 +46,7 @@ library Gundeck.Schema.Run Gundeck.Schema.V1 Gundeck.Schema.V10 + Gundeck.Schema.V11 Gundeck.Schema.V2 Gundeck.Schema.V3 Gundeck.Schema.V4 @@ -110,7 +111,7 @@ library -Wredundant-constraints -Wunused-packages build-depends: - aeson >=2.0.1.0 + , aeson >=2.0.1.0 , amazonka >=2 , amazonka-core >=2 , amazonka-sns >=2 @@ -219,7 +220,7 @@ executable gundeck -Wunused-packages build-depends: - base + , base , gundeck , HsOpenSSL , imports @@ -288,7 +289,7 @@ executable gundeck-integration -threaded -Wredundant-constraints -Wunused-packages build-depends: - aeson + , aeson , async , base >=4 && <5 , base16-bytestring >=0.1 @@ -329,6 +330,81 @@ executable gundeck-integration default-language: GHC2021 +executable gundeck-migrate-data + main-is: ../main.hs + hs-source-dirs: migrate-data/src + default-extensions: + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -threaded -Wredundant-constraints -Wunused-packages + + -- cabal-fmt: expand migrate-data/src + other-modules: + Gundeck.DataMigration + Gundeck.DataMigration.Types + Run + V1_DeleteApnsVoipTokens + + build-depends: + , base + , cassandra-util + , conduit + , exceptions + , extended + , imports + , optparse-applicative + , text + , time + , tinylog + , types-common + + if flag(static) + ld-options: -static + + default-language: GHC2021 + executable gundeck-schema main-is: Main.hs hs-source-dirs: schema @@ -380,7 +456,7 @@ executable gundeck-schema -threaded -Wredundant-constraints -Wunused-packages build-depends: - gundeck + , gundeck , imports if flag(static) @@ -451,7 +527,7 @@ test-suite gundeck-tests -threaded -Wredundant-constraints -Wunused-packages build-depends: - aeson + , aeson , aeson-pretty , amazonka , amazonka-core @@ -540,7 +616,7 @@ benchmark gundeck-bench -Wredundant-constraints -Wunused-packages build-depends: - amazonka + , amazonka , base , criterion , gundeck diff --git a/services/gundeck/migrate-data/main.hs b/services/gundeck/migrate-data/main.hs new file mode 100644 index 00000000000..a26473d24ee --- /dev/null +++ b/services/gundeck/migrate-data/main.hs @@ -0,0 +1 @@ +import Run diff --git a/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs b/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs new file mode 100644 index 00000000000..6c01b748bf7 --- /dev/null +++ b/services/gundeck/migrate-data/src/Gundeck/DataMigration.hs @@ -0,0 +1,120 @@ +-- 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 Gundeck.DataMigration (cassandraSettingsParser, migrate) where + +import Cassandra qualified as C +import Cassandra.Options +import Cassandra.Util (defInitCassandra) +import Control.Monad.Catch (finally) +import Data.Text qualified as Text +import Data.Time (UTCTime, getCurrentTime) +import Gundeck.DataMigration.Types +import Imports +import Options.Applicative (Parser) +import Options.Applicative qualified as Opts +import System.Logger.Class (Logger) +import System.Logger.Class qualified as Log + +data CassandraSettings = CassandraSettings + { cHost :: String, + cPort :: Word16, + cKeyspace :: C.Keyspace, + cTlsCa :: Maybe FilePath + } + +toCassandraOpts :: CassandraSettings -> CassandraOpts +toCassandraOpts cas = + CassandraOpts + { _endpoint = Endpoint (Text.pack (cas.cHost)) (cas.cPort), + _keyspace = C.unKeyspace (cas.cKeyspace), + _filterNodesByDatacentre = Nothing, + _tlsCa = cas.cTlsCa + } + +cassandraSettingsParser :: Parser CassandraSettings +cassandraSettingsParser = + CassandraSettings + <$> Opts.strOption + ( Opts.long "cassandra-host" + <> Opts.value "localhost" + ) + <*> Opts.option + Opts.auto + ( Opts.long "cassandra-port" + <> Opts.value 9042 + ) + <*> ( C.Keyspace + <$> Opts.strOption + ( Opts.long "cassandra-keyspace" + <> Opts.value "gundeck_test" + ) + ) + <*> ( (Opts.optional . Opts.strOption) + ( Opts.long "tls-ca-certificate-file" + <> Opts.help "Location of a PEM encoded list of CA certificates to be used when verifying the Cassandra server's certificate" + ) + ) + +migrate :: Logger -> CassandraSettings -> [Migration] -> IO () +migrate l cas ms = do + env <- mkEnv l cas + finally (go env) (cleanup env) + where + go env = + runMigrationAction env $ + runMigrations ms + +mkEnv :: Logger -> CassandraSettings -> IO Env +mkEnv l cas = + Env + <$> initCassandra + <*> initLogger + where + initCassandra = defInitCassandra (toCassandraOpts cas) l + initLogger = pure l + +-- | Runs only the migrations which need to run +runMigrations :: [Migration] -> MigrationActionT IO () +runMigrations migrations = do + vmax <- latestMigrationVersion + let pendingMigrations = filter (\m -> version m > vmax) migrations + if null pendingMigrations + then info "No new migrations." + else info "New migrations found." + mapM_ runMigration pendingMigrations + +runMigration :: Migration -> MigrationActionT IO () +runMigration (Migration ver txt mig) = do + info $ "Running: [" <> show (migrationVersion ver) <> "] " <> Text.unpack txt + mig + persistVersion ver txt =<< liftIO getCurrentTime + +latestMigrationVersion :: MigrationActionT IO MigrationVersion +latestMigrationVersion = MigrationVersion . maybe 0 fromIntegral <$> C.query1 cql (C.params C.LocalQuorum ()) + where + cql :: C.QueryString C.R () (Identity Int32) + cql = "select version from data_migration where id=1 order by version desc limit 1" + +persistVersion :: MigrationVersion -> Text -> UTCTime -> MigrationActionT IO () +persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.LocalQuorum (fromIntegral v, desc, time)) + where + cql :: C.QueryString C.W (Int32, Text, UTCTime) () + cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" + +info :: Log.MonadLogger m => String -> m () +info = Log.info . Log.msg diff --git a/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs b/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs new file mode 100644 index 00000000000..4ad3dbb20d9 --- /dev/null +++ b/services/gundeck/migrate-data/src/Gundeck/DataMigration/Types.hs @@ -0,0 +1,78 @@ +{-# 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 Gundeck.DataMigration.Types where + +import Cassandra qualified as C +import Control.Monad.Catch (MonadThrow) +import Imports +import Numeric.Natural (Natural) +import System.Logger qualified as Logger +import System.Logger.Class (MonadLogger (..)) + +data Migration = Migration + { version :: MigrationVersion, + text :: Text, + action :: MigrationActionT IO () + } + +newtype MigrationVersion = MigrationVersion {migrationVersion :: Natural} + deriving (Show, Eq, Ord) + +newtype MigrationActionT m a = MigrationActionT {unMigrationAction :: ReaderT Env m a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadReader Env, + MonadUnliftIO + ) + +instance MonadTrans MigrationActionT where + lift = MigrationActionT . lift + +instance (MonadIO m, MonadThrow m) => C.MonadClient (MigrationActionT m) where + liftClient = liftCassandra + localState f = local (\env -> env {cassandraClientState = f $ cassandraClientState env}) + +instance MonadIO m => MonadLogger (MigrationActionT m) where + log level f = do + env <- ask + Logger.log (logger env) level f + +data Env = Env + { cassandraClientState :: C.ClientState, + logger :: Logger.Logger + } + +runMigrationAction :: Env -> MigrationActionT m a -> m a +runMigrationAction env action = + runReaderT (unMigrationAction action) env + +liftCassandra :: MonadIO m => C.Client a -> MigrationActionT m a +liftCassandra m = do + env <- ask + lift $ C.runClient (cassandraClientState env) m + +cleanup :: (MonadIO m) => Env -> m () +cleanup env = do + C.shutdown (cassandraClientState env) + Logger.close (logger env) diff --git a/services/gundeck/migrate-data/src/Run.hs b/services/gundeck/migrate-data/src/Run.hs new file mode 100644 index 00000000000..655851e58a1 --- /dev/null +++ b/services/gundeck/migrate-data/src/Run.hs @@ -0,0 +1,32 @@ +-- 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 Run where + +import Gundeck.DataMigration +import Imports +import Options.Applicative +import System.Logger.Extended qualified as Log +import V1_DeleteApnsVoipTokens qualified + +main :: IO () +main = do + o <- execParser (info (helper <*> cassandraSettingsParser) desc) + l <- Log.mkLogger Log.Debug Nothing Nothing + migrate l o [V1_DeleteApnsVoipTokens.migration] + where + desc = header "Gundeck Cassandra Data Migrations" <> fullDesc diff --git a/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs b/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs new file mode 100644 index 00000000000..0c7645797b8 --- /dev/null +++ b/services/gundeck/migrate-data/src/V1_DeleteApnsVoipTokens.hs @@ -0,0 +1,90 @@ +-- 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 V1_DeleteApnsVoipTokens where + +import Cassandra +import Conduit +import Data.Conduit.Internal (zipSources) +import Data.Conduit.List qualified as C +import Data.Id +import Data.Text qualified as Text +import Gundeck.DataMigration.Types +import Imports +import System.Logger.Class qualified as Log + +migration :: Migration +migration = + Migration + { version = MigrationVersion 1, + text = "Delete APNS_VOIP push tokens", + action = + runConduit $ + zipSources + (C.sourceList [(1 :: Int32) ..]) + getPushTokens + .| C.mapM + ( \(i, p) -> + Log.info (Log.field "push tokens" (show (i * pageSize))) + >> pure p + ) + .| C.concatMap (filter isVoipToken) + .| C.map (\(uid, token, app, transport, _mArn) -> (uid, token, app, transport)) + .| C.mapM_ deletePushToken + } + +pageSize :: Int32 +pageSize = 1000 + +---------------------------------------------------------------------------- +-- Queries + +-- | We do not use the push token types here because they will likely be +-- changed in future breaking this migration. +getPushTokens :: + MonadClient m => + ConduitM () [(UserId, Text, Text, Int32, Maybe Text)] m () +getPushTokens = paginateC cql (paramsP LocalQuorum () pageSize) x5 + where + cql :: PrepQuery R () (UserId, Text, Text, Int32, Maybe Text) + cql = "SELECT usr, ptoken, app, transport, arn FROM user_push" + +deletePushToken :: MonadClient m => (UserId, Text, Text, Int32) -> m () +deletePushToken pair = + retry x5 $ write cql (params LocalQuorum pair) + where + cql :: PrepQuery W (UserId, Text, Text, Int32) () + cql = "DELETE FROM user_push where usr = ? AND ptoken = ? AND app = ? AND transport = ?" + +isVoipTransport :: Int32 -> Bool +isVoipTransport 3 = True -- APNS_VOIP +isVoipTransport 4 = True -- APNS_VOIP_SANDBOX +isVoipTransport _ = False + +isVoipArn :: Text -> Bool +isVoipArn arn = + case Text.splitOn ":" arn of + ["arn", "aws", "sns", _region, _accountId, topic] -> + case Text.splitOn "/" topic of + ("endpoint" : "APNS_VOIP" : _) -> True + ("endpoint" : "APNS_VOIP_SANDBOX" : _) -> True + _ -> False + _ -> False + +isVoipToken :: (UserId, Text, Text, Int32, Maybe Text) -> Bool +isVoipToken (_, _, _, transport, mArn) = + isVoipTransport transport || maybe False isVoipArn mArn diff --git a/services/gundeck/src/Gundeck/Schema/Run.hs b/services/gundeck/src/Gundeck/Schema/Run.hs index ccec5141e4f..247f7a69488 100644 --- a/services/gundeck/src/Gundeck/Schema/Run.hs +++ b/services/gundeck/src/Gundeck/Schema/Run.hs @@ -22,6 +22,7 @@ import Cassandra.Schema import Control.Exception (finally) import Gundeck.Schema.V1 qualified as V1 import Gundeck.Schema.V10 qualified as V10 +import Gundeck.Schema.V11 qualified as V11 import Gundeck.Schema.V2 qualified as V2 import Gundeck.Schema.V3 qualified as V3 import Gundeck.Schema.V4 qualified as V4 @@ -61,5 +62,6 @@ migrations = V7.migration, V8.migration, V9.migration, - V10.migration + V10.migration, + V11.migration ] diff --git a/services/gundeck/src/Gundeck/Schema/V11.hs b/services/gundeck/src/Gundeck/Schema/V11.hs new file mode 100644 index 00000000000..c734aab0a2f --- /dev/null +++ b/services/gundeck/src/Gundeck/Schema/V11.hs @@ -0,0 +1,35 @@ +-- 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 Gundeck.Schema.V11 (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 11 "Create table `data_migration`" $ do + schema' + [r| + CREATE TABLE data_migration ( + id int, + version int, + descr text, + date timestamp, + PRIMARY KEY (id, version) + ); + |] From f37c4372d84d4fd5973903f77a3f5a21d13bc1ed Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 15 May 2024 22:38:59 +0200 Subject: [PATCH 19/30] Fix hardcoded use of ciphersuite 1 when switching to mixed protocol (#4048) --- changelog.d/3-bug-fixes/mixed-ciphersuite | 1 + integration/test/Test/MLS.hs | 15 +++++++++++++-- services/galley/src/Galley/API/Action.hs | 3 +-- .../galley/src/Galley/Cassandra/Conversation.hs | 9 ++++----- services/galley/src/Galley/Cassandra/Queries.hs | 4 ++-- .../src/Galley/Effects/ConversationStore.hs | 2 +- 6 files changed, 22 insertions(+), 12 deletions(-) create mode 100644 changelog.d/3-bug-fixes/mixed-ciphersuite diff --git a/changelog.d/3-bug-fixes/mixed-ciphersuite b/changelog.d/3-bug-fixes/mixed-ciphersuite new file mode 100644 index 00000000000..cdc337dd74b --- /dev/null +++ b/changelog.d/3-bug-fixes/mixed-ciphersuite @@ -0,0 +1 @@ +Fix hardcoded ciphersuite when switching to mixed diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index aba592e4ecf..dcf18eb99dc 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -8,7 +8,9 @@ import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as Set +import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Read as T import MLS.Util import Notifications import SetupHelpers @@ -101,6 +103,7 @@ testMixedProtocolUpgrade secondDomain = do bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "protocol" `shouldMatch` "mixed" + resp.json %. "epoch" `shouldMatchInt` 0 bindResponse (putConversationProtocol alice qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 204 @@ -121,8 +124,9 @@ testMixedProtocolNonTeam secondDomain = do bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do resp.status `shouldMatchInt` 403 -testMixedProtocolAddUsers :: HasCallStack => Domain -> App () -testMixedProtocolAddUsers secondDomain = do +testMixedProtocolAddUsers :: HasCallStack => Domain -> Ciphersuite -> App () +testMixedProtocolAddUsers secondDomain suite = do + setMLSCiphersuite suite (alice, tid, _) <- createTeam OwnDomain 1 [bob, charlie] <- replicateM 2 (randomUser secondDomain def) connectUsers [alice, bob, charlie] @@ -139,6 +143,7 @@ testMixedProtocolAddUsers secondDomain = do bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 + resp.json %. "epoch" `shouldMatchInt` 0 createGroup alice1 resp.json traverse_ uploadNewKeyPackage [bob1] @@ -150,6 +155,12 @@ testMixedProtocolAddUsers secondDomain = do n <- awaitMatch (\n -> nPayload n %. "type" `isEqual` "conversation.mls-welcome") ws nPayload n %. "data" `shouldMatch` T.decodeUtf8 (Base64.encode welcome) + bindResponse (getConversation alice qcnv) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "epoch" `shouldMatchInt` 1 + (suiteCode, _) <- assertOne $ T.hexadecimal (T.pack suite.code) + resp.json %. "cipher_suite" `shouldMatchInt` suiteCode + testMixedProtocolUserLeaves :: HasCallStack => Domain -> App () testMixedProtocolUserLeaves secondDomain = do (alice, tid, _) <- createTeam OwnDomain 1 diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 156954e3131..23a3ecb106c 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -117,7 +117,6 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as F import Wire.API.Federation.Error import Wire.API.FederationStatus -import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Feature import Wire.API.Team.LegalHold @@ -492,7 +491,7 @@ performAction tag origUser lconv action = do SConversationUpdateProtocolTag -> do case (protocolTag (convProtocol (tUnqualified lconv)), action, convTeam (tUnqualified lconv)) of (ProtocolProteusTag, ProtocolMixedTag, Just _) -> do - E.updateToMixedProtocol lcnv (convType (tUnqualified lconv)) MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + E.updateToMixedProtocol lcnv (convType (tUnqualified lconv)) pure (mempty, action) (ProtocolMixedTag, ProtocolMLSTag, Just tid) -> do mig <- getFeatureStatus @MlsMigrationConfig DontDoAuth tid diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 2fb941c3e7b..919b7b21836 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -396,15 +396,14 @@ updateToMixedProtocol :: r => Local ConvId -> ConvType -> - CipherSuiteTag -> Sem r () -updateToMixedProtocol lcnv ct cs = do +updateToMixedProtocol lcnv ct = do let gid = convToGroupId . groupIdParts ct $ Conv <$> tUntagged lcnv epoch = Epoch 0 embedClient . retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery Cql.updateToMixedConv (tUnqualified lcnv, ProtocolMixedTag, gid, epoch, cs) + addPrepQuery Cql.updateToMixedConv (tUnqualified lcnv, ProtocolMixedTag, gid, epoch) pure () updateToMLSProtocol :: @@ -493,9 +492,9 @@ interpretConversationStoreToCassandra = interpret $ \case ReleaseCommitLock gId epoch -> do logEffect "ConversationStore.ReleaseCommitLock" embedClient $ releaseCommitLock gId epoch - UpdateToMixedProtocol cid ct cs -> do + UpdateToMixedProtocol cid ct -> do logEffect "ConversationStore.UpdateToMixedProtocol" - updateToMixedProtocol cid ct cs + updateToMixedProtocol cid ct UpdateToMLSProtocol cid -> do logEffect "ConversationStore.UpdateToMLSProtocol" updateToMLSProtocol cid diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 588053ada63..fa8c5c89042 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -267,9 +267,9 @@ insertMLSSelfConv = <> show (fromEnum ProtocolMLSTag) <> ", ?)" -updateToMixedConv :: PrepQuery W (ConvId, ProtocolTag, GroupId, Epoch, CipherSuiteTag) () +updateToMixedConv :: PrepQuery W (ConvId, ProtocolTag, GroupId, Epoch) () updateToMixedConv = - "insert into conversation (conv, protocol, group_id, epoch, cipher_suite) values (?, ?, ?, ?, ?)" + "insert into conversation (conv, protocol, group_id, epoch) values (?, ?, ?, ?)" updateToMLSConv :: PrepQuery W (ConvId, ProtocolTag) () updateToMLSConv = "insert into conversation (conv, protocol) values (?, ?)" diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs index cd0a2e8dce7..234dfa64bda 100644 --- a/services/galley/src/Galley/Effects/ConversationStore.hs +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -101,7 +101,7 @@ data ConversationStore m a where SetGroupInfo :: ConvId -> GroupInfoData -> ConversationStore m () AcquireCommitLock :: GroupId -> Epoch -> NominalDiffTime -> ConversationStore m LockAcquired ReleaseCommitLock :: GroupId -> Epoch -> ConversationStore m () - UpdateToMixedProtocol :: Local ConvId -> ConvType -> CipherSuiteTag -> ConversationStore m () + UpdateToMixedProtocol :: Local ConvId -> ConvType -> ConversationStore m () UpdateToMLSProtocol :: Local ConvId -> ConversationStore m () makeSem ''ConversationStore From 003c9d0f857733f8cea6ea967d2f3a0c4bec9cc6 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 08:35:25 +0000 Subject: [PATCH 20/30] updated mlse2eid config and nwe api version --- libs/wire-api/src/Wire/API/Routes/Named.hs | 2 ++ .../src/Wire/API/Routes/Public/Galley/Feature.hs | 3 ++- libs/wire-api/src/Wire/API/Team/Feature.hs | 16 ++++++++++++++-- .../Wire/API/Golden/Generated/WithStatus_team.hs | 2 ++ .../golden/testObject_WithStatus_team_18.json | 3 ++- services/galley/src/Galley/API/Public/Feature.hs | 1 + .../Galley/Cassandra/GetAllTeamFeatureConfigs.hs | 2 ++ .../galley/src/Galley/Cassandra/TeamFeatures.hs | 3 ++- 8 files changed, 27 insertions(+), 5 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 5e8220818b5..71e0ec307cb 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -142,6 +142,8 @@ namedClient = clientIn (Proxy @endpoint) (Proxy @m) type family x ::> api +infixr 4 ::> + type instance x ::> (Named name api) = Named name (x :> api) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index 3dab419273e..654f79657a2 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -88,7 +88,8 @@ type FeatureAPI = :<|> FeatureStatusGet OutlookCalIntegrationConfig :<|> FeatureStatusPut '[] '() OutlookCalIntegrationConfig :<|> From 'V5 ::> FeatureStatusGet MlsE2EIdConfig - :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsE2EIdConfig + :<|> From 'V5 ::> Until 'V6 ::> Named "put-MlsE2EIdConfig@v5" (ZUser :> FeatureStatusBasePutPublic '() MlsE2EIdConfig) + :<|> From 'V6 ::> FeatureStatusPut '[] '() MlsE2EIdConfig :<|> From 'V5 ::> FeatureStatusGet MlsMigrationConfig :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsMigrationConfig :<|> From 'V5 diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 55319e388d4..33a852ab5d8 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -80,6 +80,7 @@ module Wire.API.Team.Feature MLSConfig (..), OutlookCalIntegrationConfig (..), MlsE2EIdConfig (..), + MlsE2EIdConfigV5Symbol, MlsMigrationConfig (..), EnforceFileDownloadLocationConfig (..), LimitedEventFanoutConfig (..), @@ -1009,10 +1010,17 @@ instance FeatureTrivialConfig OutlookCalIntegrationConfig where data MlsE2EIdConfig = MlsE2EIdConfig { verificationExpiration :: NominalDiffTime, - acmeDiscoveryUrl :: Maybe HttpsUrl + acmeDiscoveryUrl :: Maybe HttpsUrl, + crlProxy :: Maybe HttpsUrl, + useProxyOnMobile :: Bool } deriving stock (Eq, Show, Generic) +data MlsE2EIdConfigV5Symbol + +instance RenderableSymbol MlsE2EIdConfigV5Symbol where + renderSymbol = "MlsE2EIdConfig@v5" + instance RenderableSymbol MlsE2EIdConfig where renderSymbol = "MlsE2EIdConfig" @@ -1021,6 +1029,8 @@ instance Arbitrary MlsE2EIdConfig where MlsE2EIdConfig <$> (fromIntegral <$> (arbitrary @Word32)) <*> arbitrary + <*> fmap Just arbitrary + <*> arbitrary instance ToSchema MlsE2EIdConfig where schema :: ValueSchema NamedSwaggerDoc MlsE2EIdConfig @@ -1029,6 +1039,8 @@ instance ToSchema MlsE2EIdConfig where MlsE2EIdConfig <$> (toSeconds . verificationExpiration) .= fieldWithDocModifier "verificationExpiration" veDesc (fromSeconds <$> schema) <*> acmeDiscoveryUrl .= maybe_ (optField "acmeDiscoveryUrl" schema) + <*> crlProxy .= maybe_ (optField "crlProxy" schema) + <*> useProxyOnMobile .= (fromMaybe False <$> optField "useProxyOnMobile" schema) where fromSeconds :: Int -> NominalDiffTime fromSeconds = fromIntegral @@ -1055,7 +1067,7 @@ instance IsFeatureConfig MlsE2EIdConfig where type FeatureSymbol MlsE2EIdConfig = "mlsE2EId" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked defValue FeatureTTLUnlimited where - defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing + defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs index 22ea58eba03..545450f91b5 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs @@ -83,6 +83,8 @@ testObject_WithStatus_team_18 = ( MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing + Nothing + False ) withStatus :: FeatureStatus -> LockStatus -> cfg -> WithStatus cfg diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json index 43f81b018eb..00044051044 100644 --- a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json +++ b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json @@ -1,6 +1,7 @@ { "config": { - "verificationExpiration": 86400 + "verificationExpiration": 86400, + "useProxyOnMobile": false }, "lockStatus": "locked", "status": "enabled", diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 61fc38c87b8..8d990d57d94 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -62,6 +62,7 @@ featureAPI = <@> mkNamedAPI @'("get", OutlookCalIntegrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", OutlookCalIntegrationConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", MlsE2EIdConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @"put-MlsE2EIdConfig@v5" (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", MlsE2EIdConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", MlsMigrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", MlsMigrationConfig) (setFeatureStatus . DoAuth) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index d6b070c7f91..5aafab51168 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -295,6 +295,8 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT MlsE2EIdConfig (toGracePeriodOrDefault row.mlsE2eidGracePeriod) row.mlsE2eidAcmeDiscoverUrl + (error "TODO:(leif)") + (error "TODO:(leif)") where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index dc8e82fe6ce..613d94632f3 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -177,7 +177,8 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do fs ( -- FUTUREWORK: this block is duplicated in -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! - MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl + -- TODO(leif): implement the missing fields + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl Nothing False ) FeatureTTLUnlimited where From 8e5588d626a05b1aa8d0714bff4794c7ac85aa6a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 08:53:43 +0000 Subject: [PATCH 21/30] db migration --- cassandra-schema.cql | 2 ++ services/galley/galley.cabal | 1 + services/galley/src/Galley/Schema/Run.hs | 4 ++- .../src/Galley/Schema/V92_MlsE2EIdConfig.hs | 31 +++++++++++++++++++ 4 files changed, 37 insertions(+), 1 deletion(-) create mode 100644 services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs diff --git a/cassandra-schema.cql b/cassandra-schema.cql index 06052e52b77..bbeefe5b6e3 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1205,9 +1205,11 @@ CREATE TABLE galley_test.team_features ( mls_default_ciphersuite int, mls_default_protocol int, mls_e2eid_acme_discovery_url blob, + mls_e2eid_crl_proxy blob, mls_e2eid_grace_period int, mls_e2eid_lock_status int, mls_e2eid_status int, + mls_e2eid_use_proxy_on_mobile boolean, mls_e2eid_ver_exp timestamp, mls_lock_status int, mls_migration_finalise_regardless_after timestamp, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 2c51515dbdb..25e88c7ae18 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -271,6 +271,7 @@ library Galley.Schema.V89_MlsLockStatus Galley.Schema.V90_EnforceFileDownloadLocationConfig Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout + Galley.Schema.V92_MlsE2EIdConfig Galley.Types.Clients Galley.Types.ToUserRole Galley.Types.UserList diff --git a/services/galley/src/Galley/Schema/Run.hs b/services/galley/src/Galley/Schema/Run.hs index 51e29417032..5039676a3fa 100644 --- a/services/galley/src/Galley/Schema/Run.hs +++ b/services/galley/src/Galley/Schema/Run.hs @@ -92,6 +92,7 @@ import Galley.Schema.V88_RemoveMemberClientAndTruncateMLSGroupMemberClient quali import Galley.Schema.V89_MlsLockStatus qualified as V89_MlsLockStatus import Galley.Schema.V90_EnforceFileDownloadLocationConfig qualified as V90_EnforceFileDownloadLocationConfig import Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout qualified as V91_TeamMemberDeletedLimitedEventFanout +import Galley.Schema.V92_MlsE2EIdConfig qualified as V92_MlsE2EIdConfig import Imports import Options.Applicative import System.Logger.Extended qualified as Log @@ -184,7 +185,8 @@ migrations = V88_RemoveMemberClientAndTruncateMLSGroupMemberClient.migration, V89_MlsLockStatus.migration, V90_EnforceFileDownloadLocationConfig.migration, - V91_TeamMemberDeletedLimitedEventFanout.migration + V91_TeamMemberDeletedLimitedEventFanout.migration, + V92_MlsE2EIdConfig.migration -- FUTUREWORK: once #1726 has made its way to master/production, -- the 'message' field in connections table can be dropped. -- See also https://github.com/wireapp/wire-server/pull/1747/files diff --git a/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs b/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs new file mode 100644 index 00000000000..0c11ebf6cd6 --- /dev/null +++ b/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2023 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 Galley.Schema.V92_MlsE2EIdConfig where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 92 "Add mls_e2eid_crl_proxy and mls_e2eid_use_proxy_on_mobile to team_features" $ + schema' + [r| ALTER TABLE team_features ADD ( + mls_e2eid_crl_proxy blob, + mls_e2eid_use_proxy_on_mobile boolean + ) + |] From 325832d4278005ac2ff1210d84633e888bed70c8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 08:54:00 +0000 Subject: [PATCH 22/30] clean up --- libs/wire-api/src/Wire/API/Team/Feature.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 33a852ab5d8..a00df05f2bd 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -80,7 +80,6 @@ module Wire.API.Team.Feature MLSConfig (..), OutlookCalIntegrationConfig (..), MlsE2EIdConfig (..), - MlsE2EIdConfigV5Symbol, MlsMigrationConfig (..), EnforceFileDownloadLocationConfig (..), LimitedEventFanoutConfig (..), @@ -1016,10 +1015,6 @@ data MlsE2EIdConfig = MlsE2EIdConfig } deriving stock (Eq, Show, Generic) -data MlsE2EIdConfigV5Symbol - -instance RenderableSymbol MlsE2EIdConfigV5Symbol where - renderSymbol = "MlsE2EIdConfig@v5" instance RenderableSymbol MlsE2EIdConfig where renderSymbol = "MlsE2EIdConfig" From 37ee52db0308c5d95a8a0b0eaf0eb9967fb2544c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 09:55:25 +0000 Subject: [PATCH 23/30] impl db layer --- .../Cassandra/GetAllTeamFeatureConfigs.hs | 10 +++++++--- .../src/Galley/Cassandra/TeamFeatures.hs | 19 ++++++++++--------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 5aafab51168..7e35b485851 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -58,6 +58,8 @@ data AllTeamFeatureConfigsRow = AllTeamFeatureConfigsRow mlsE2eid :: Maybe FeatureStatus, mlsE2eidGracePeriod :: Maybe Int32, mlsE2eidAcmeDiscoverUrl :: Maybe HttpsUrl, + mlsE2eidMaybeCrlProxy :: Maybe HttpsUrl, + mlsE2eidMaybeUseProxyOnMobile :: Maybe Bool, mlsE2eidLock :: Maybe LockStatus, -- mls migration mlsMigration :: Maybe FeatureStatus, @@ -112,6 +114,8 @@ emptyRow = mlsE2eid = Nothing, mlsE2eidGracePeriod = Nothing, mlsE2eidAcmeDiscoverUrl = Nothing, + mlsE2eidMaybeCrlProxy = Nothing, + mlsE2eidMaybeUseProxyOnMobile = Nothing, mlsE2eidLock = Nothing, mlsMigration = Nothing, mlsMigrationStartTime = Nothing, @@ -295,8 +299,8 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT MlsE2EIdConfig (toGracePeriodOrDefault row.mlsE2eidGracePeriod) row.mlsE2eidAcmeDiscoverUrl - (error "TODO:(leif)") - (error "TODO:(leif)") + row.mlsE2eidMaybeCrlProxy + (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus) row.mlsE2eidMaybeUseProxyOnMobile) where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral @@ -370,7 +374,7 @@ getAllFeatureConfigs allowListForExposeInvitationURLs featureLH hasTeamImplicitL \mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ \mls_default_ciphersuite, mls_supported_protocols, mls_lock_status, \ \\ - \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_lock_status, \ + \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile, mls_e2eid_lock_status, \ \\ \mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after, \ \mls_migration_lock_status, \ diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 613d94632f3..653f2022612 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -170,25 +170,24 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case Nothing -> Nothing - Just (Nothing, _, _) -> Nothing - Just (Just fs, mGracePeriod, mUrl) -> + Just (Nothing, _, _,_,_) -> Nothing + Just (Just fs, mGracePeriod, mUrl, mCrlProxy, mUseProxyOnMobile) -> Just $ WithStatusNoLock fs ( -- FUTUREWORK: this block is duplicated in -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! - -- TODO(leif): implement the missing fields - MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl Nothing False + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl mCrlProxy (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus @MlsE2EIdConfig) mUseProxyOnMobile) ) FeatureTTLUnlimited where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl) + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl, Maybe HttpsUrl, Maybe Bool) select = fromString $ - "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url from team_features where team_id = ?" + "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile from team_features where team_id = ?" getFeatureConfig FeatureSingletonMlsMigration tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case @@ -293,11 +292,13 @@ setFeatureConfig FeatureSingletonMlsE2EIdConfig tid status = do let statusValue = wssStatus status vex = verificationExpiration . wssConfig $ status mUrl = acmeDiscoveryUrl . wssConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl)) + mCrlProxy = crlProxy . wssConfig $ status + useProxy = useProxyOnMobile . wssConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl, mCrlProxy, useProxy)) where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl) () + insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl, Maybe HttpsUrl, Bool) () insert = - "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url) values (?, ?, ?, ?)" + "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile) values (?, ?, ?, ?, ?, ?)" setFeatureConfig FeatureSingletonMlsMigration tid status = do let statusValue = wssStatus status config = wssConfig status From e35b0b50fb34af1b5d759acfc8a1c14b89427281 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 10:00:34 +0000 Subject: [PATCH 24/30] Revert "impl db layer" This reverts commit 37ee52db0308c5d95a8a0b0eaf0eb9967fb2544c. --- .../Cassandra/GetAllTeamFeatureConfigs.hs | 10 +++------- .../src/Galley/Cassandra/TeamFeatures.hs | 19 +++++++++---------- 2 files changed, 12 insertions(+), 17 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 7e35b485851..5aafab51168 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -58,8 +58,6 @@ data AllTeamFeatureConfigsRow = AllTeamFeatureConfigsRow mlsE2eid :: Maybe FeatureStatus, mlsE2eidGracePeriod :: Maybe Int32, mlsE2eidAcmeDiscoverUrl :: Maybe HttpsUrl, - mlsE2eidMaybeCrlProxy :: Maybe HttpsUrl, - mlsE2eidMaybeUseProxyOnMobile :: Maybe Bool, mlsE2eidLock :: Maybe LockStatus, -- mls migration mlsMigration :: Maybe FeatureStatus, @@ -114,8 +112,6 @@ emptyRow = mlsE2eid = Nothing, mlsE2eidGracePeriod = Nothing, mlsE2eidAcmeDiscoverUrl = Nothing, - mlsE2eidMaybeCrlProxy = Nothing, - mlsE2eidMaybeUseProxyOnMobile = Nothing, mlsE2eidLock = Nothing, mlsMigration = Nothing, mlsMigrationStartTime = Nothing, @@ -299,8 +295,8 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT MlsE2EIdConfig (toGracePeriodOrDefault row.mlsE2eidGracePeriod) row.mlsE2eidAcmeDiscoverUrl - row.mlsE2eidMaybeCrlProxy - (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus) row.mlsE2eidMaybeUseProxyOnMobile) + (error "TODO:(leif)") + (error "TODO:(leif)") where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral @@ -374,7 +370,7 @@ getAllFeatureConfigs allowListForExposeInvitationURLs featureLH hasTeamImplicitL \mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ \mls_default_ciphersuite, mls_supported_protocols, mls_lock_status, \ \\ - \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile, mls_e2eid_lock_status, \ + \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_lock_status, \ \\ \mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after, \ \mls_migration_lock_status, \ diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 653f2022612..613d94632f3 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -170,24 +170,25 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case Nothing -> Nothing - Just (Nothing, _, _,_,_) -> Nothing - Just (Just fs, mGracePeriod, mUrl, mCrlProxy, mUseProxyOnMobile) -> + Just (Nothing, _, _) -> Nothing + Just (Just fs, mGracePeriod, mUrl) -> Just $ WithStatusNoLock fs ( -- FUTUREWORK: this block is duplicated in -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! - MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl mCrlProxy (fromMaybe (useProxyOnMobile . wsConfig $ defFeatureStatus @MlsE2EIdConfig) mUseProxyOnMobile) + -- TODO(leif): implement the missing fields + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl Nothing False ) FeatureTTLUnlimited where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl, Maybe HttpsUrl, Maybe Bool) + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl) select = fromString $ - "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile from team_features where team_id = ?" + "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url from team_features where team_id = ?" getFeatureConfig FeatureSingletonMlsMigration tid = do let q = query1 select (params LocalQuorum (Identity tid)) retry x1 q <&> \case @@ -292,13 +293,11 @@ setFeatureConfig FeatureSingletonMlsE2EIdConfig tid status = do let statusValue = wssStatus status vex = verificationExpiration . wssConfig $ status mUrl = acmeDiscoveryUrl . wssConfig $ status - mCrlProxy = crlProxy . wssConfig $ status - useProxy = useProxyOnMobile . wssConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl, mCrlProxy, useProxy)) + retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl)) where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl, Maybe HttpsUrl, Bool) () + insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl) () insert = - "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile) values (?, ?, ?, ?, ?, ?)" + "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url) values (?, ?, ?, ?)" setFeatureConfig FeatureSingletonMlsMigration tid status = do let statusValue = wssStatus status config = wssConfig status From 695d769ea2c611db8fb4072f661560dad089e58a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 10:00:46 +0000 Subject: [PATCH 25/30] Revert "clean up" This reverts commit 325832d4278005ac2ff1210d84633e888bed70c8. --- libs/wire-api/src/Wire/API/Team/Feature.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index a00df05f2bd..33a852ab5d8 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -80,6 +80,7 @@ module Wire.API.Team.Feature MLSConfig (..), OutlookCalIntegrationConfig (..), MlsE2EIdConfig (..), + MlsE2EIdConfigV5Symbol, MlsMigrationConfig (..), EnforceFileDownloadLocationConfig (..), LimitedEventFanoutConfig (..), @@ -1015,6 +1016,10 @@ data MlsE2EIdConfig = MlsE2EIdConfig } deriving stock (Eq, Show, Generic) +data MlsE2EIdConfigV5Symbol + +instance RenderableSymbol MlsE2EIdConfigV5Symbol where + renderSymbol = "MlsE2EIdConfig@v5" instance RenderableSymbol MlsE2EIdConfig where renderSymbol = "MlsE2EIdConfig" From 691c3e77f495a8494a406534f3253a03343adcc1 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 10:00:55 +0000 Subject: [PATCH 26/30] Revert "db migration" This reverts commit 8e5588d626a05b1aa8d0714bff4794c7ac85aa6a. --- cassandra-schema.cql | 2 -- services/galley/galley.cabal | 1 - services/galley/src/Galley/Schema/Run.hs | 4 +-- .../src/Galley/Schema/V92_MlsE2EIdConfig.hs | 31 ------------------- 4 files changed, 1 insertion(+), 37 deletions(-) delete mode 100644 services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs diff --git a/cassandra-schema.cql b/cassandra-schema.cql index bbeefe5b6e3..06052e52b77 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1205,11 +1205,9 @@ CREATE TABLE galley_test.team_features ( mls_default_ciphersuite int, mls_default_protocol int, mls_e2eid_acme_discovery_url blob, - mls_e2eid_crl_proxy blob, mls_e2eid_grace_period int, mls_e2eid_lock_status int, mls_e2eid_status int, - mls_e2eid_use_proxy_on_mobile boolean, mls_e2eid_ver_exp timestamp, mls_lock_status int, mls_migration_finalise_regardless_after timestamp, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 25e88c7ae18..2c51515dbdb 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -271,7 +271,6 @@ library Galley.Schema.V89_MlsLockStatus Galley.Schema.V90_EnforceFileDownloadLocationConfig Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout - Galley.Schema.V92_MlsE2EIdConfig Galley.Types.Clients Galley.Types.ToUserRole Galley.Types.UserList diff --git a/services/galley/src/Galley/Schema/Run.hs b/services/galley/src/Galley/Schema/Run.hs index 5039676a3fa..51e29417032 100644 --- a/services/galley/src/Galley/Schema/Run.hs +++ b/services/galley/src/Galley/Schema/Run.hs @@ -92,7 +92,6 @@ import Galley.Schema.V88_RemoveMemberClientAndTruncateMLSGroupMemberClient quali import Galley.Schema.V89_MlsLockStatus qualified as V89_MlsLockStatus import Galley.Schema.V90_EnforceFileDownloadLocationConfig qualified as V90_EnforceFileDownloadLocationConfig import Galley.Schema.V91_TeamMemberDeletedLimitedEventFanout qualified as V91_TeamMemberDeletedLimitedEventFanout -import Galley.Schema.V92_MlsE2EIdConfig qualified as V92_MlsE2EIdConfig import Imports import Options.Applicative import System.Logger.Extended qualified as Log @@ -185,8 +184,7 @@ migrations = V88_RemoveMemberClientAndTruncateMLSGroupMemberClient.migration, V89_MlsLockStatus.migration, V90_EnforceFileDownloadLocationConfig.migration, - V91_TeamMemberDeletedLimitedEventFanout.migration, - V92_MlsE2EIdConfig.migration + V91_TeamMemberDeletedLimitedEventFanout.migration -- FUTUREWORK: once #1726 has made its way to master/production, -- the 'message' field in connections table can be dropped. -- See also https://github.com/wireapp/wire-server/pull/1747/files diff --git a/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs b/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs deleted file mode 100644 index 0c11ebf6cd6..00000000000 --- a/services/galley/src/Galley/Schema/V92_MlsE2EIdConfig.hs +++ /dev/null @@ -1,31 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2023 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 Galley.Schema.V92_MlsE2EIdConfig where - -import Cassandra.Schema -import Imports -import Text.RawString.QQ - -migration :: Migration -migration = - Migration 92 "Add mls_e2eid_crl_proxy and mls_e2eid_use_proxy_on_mobile to team_features" $ - schema' - [r| ALTER TABLE team_features ADD ( - mls_e2eid_crl_proxy blob, - mls_e2eid_use_proxy_on_mobile boolean - ) - |] From 34205d3d788582ff4dc530f04f735e0da19eafc8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 17 May 2024 10:01:12 +0000 Subject: [PATCH 27/30] Revert "updated mlse2eid config and nwe api version" This reverts commit 003c9d0f857733f8cea6ea967d2f3a0c4bec9cc6. --- libs/wire-api/src/Wire/API/Routes/Named.hs | 2 -- .../src/Wire/API/Routes/Public/Galley/Feature.hs | 3 +-- libs/wire-api/src/Wire/API/Team/Feature.hs | 16 ++-------------- .../Wire/API/Golden/Generated/WithStatus_team.hs | 2 -- .../golden/testObject_WithStatus_team_18.json | 3 +-- services/galley/src/Galley/API/Public/Feature.hs | 1 - .../Galley/Cassandra/GetAllTeamFeatureConfigs.hs | 2 -- .../galley/src/Galley/Cassandra/TeamFeatures.hs | 3 +-- 8 files changed, 5 insertions(+), 27 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 71e0ec307cb..5e8220818b5 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -142,8 +142,6 @@ namedClient = clientIn (Proxy @endpoint) (Proxy @m) type family x ::> api -infixr 4 ::> - type instance x ::> (Named name api) = Named name (x :> api) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index 654f79657a2..3dab419273e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -88,8 +88,7 @@ type FeatureAPI = :<|> FeatureStatusGet OutlookCalIntegrationConfig :<|> FeatureStatusPut '[] '() OutlookCalIntegrationConfig :<|> From 'V5 ::> FeatureStatusGet MlsE2EIdConfig - :<|> From 'V5 ::> Until 'V6 ::> Named "put-MlsE2EIdConfig@v5" (ZUser :> FeatureStatusBasePutPublic '() MlsE2EIdConfig) - :<|> From 'V6 ::> FeatureStatusPut '[] '() MlsE2EIdConfig + :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsE2EIdConfig :<|> From 'V5 ::> FeatureStatusGet MlsMigrationConfig :<|> From 'V5 ::> FeatureStatusPut '[] '() MlsMigrationConfig :<|> From 'V5 diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 33a852ab5d8..55319e388d4 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -80,7 +80,6 @@ module Wire.API.Team.Feature MLSConfig (..), OutlookCalIntegrationConfig (..), MlsE2EIdConfig (..), - MlsE2EIdConfigV5Symbol, MlsMigrationConfig (..), EnforceFileDownloadLocationConfig (..), LimitedEventFanoutConfig (..), @@ -1010,17 +1009,10 @@ instance FeatureTrivialConfig OutlookCalIntegrationConfig where data MlsE2EIdConfig = MlsE2EIdConfig { verificationExpiration :: NominalDiffTime, - acmeDiscoveryUrl :: Maybe HttpsUrl, - crlProxy :: Maybe HttpsUrl, - useProxyOnMobile :: Bool + acmeDiscoveryUrl :: Maybe HttpsUrl } deriving stock (Eq, Show, Generic) -data MlsE2EIdConfigV5Symbol - -instance RenderableSymbol MlsE2EIdConfigV5Symbol where - renderSymbol = "MlsE2EIdConfig@v5" - instance RenderableSymbol MlsE2EIdConfig where renderSymbol = "MlsE2EIdConfig" @@ -1029,8 +1021,6 @@ instance Arbitrary MlsE2EIdConfig where MlsE2EIdConfig <$> (fromIntegral <$> (arbitrary @Word32)) <*> arbitrary - <*> fmap Just arbitrary - <*> arbitrary instance ToSchema MlsE2EIdConfig where schema :: ValueSchema NamedSwaggerDoc MlsE2EIdConfig @@ -1039,8 +1029,6 @@ instance ToSchema MlsE2EIdConfig where MlsE2EIdConfig <$> (toSeconds . verificationExpiration) .= fieldWithDocModifier "verificationExpiration" veDesc (fromSeconds <$> schema) <*> acmeDiscoveryUrl .= maybe_ (optField "acmeDiscoveryUrl" schema) - <*> crlProxy .= maybe_ (optField "crlProxy" schema) - <*> useProxyOnMobile .= (fromMaybe False <$> optField "useProxyOnMobile" schema) where fromSeconds :: Int -> NominalDiffTime fromSeconds = fromIntegral @@ -1067,7 +1055,7 @@ instance IsFeatureConfig MlsE2EIdConfig where type FeatureSymbol MlsE2EIdConfig = "mlsE2EId" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked defValue FeatureTTLUnlimited where - defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False + defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs index 545450f91b5..22ea58eba03 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs @@ -83,8 +83,6 @@ testObject_WithStatus_team_18 = ( MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing - Nothing - False ) withStatus :: FeatureStatus -> LockStatus -> cfg -> WithStatus cfg diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json index 00044051044..43f81b018eb 100644 --- a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json +++ b/libs/wire-api/test/golden/testObject_WithStatus_team_18.json @@ -1,7 +1,6 @@ { "config": { - "verificationExpiration": 86400, - "useProxyOnMobile": false + "verificationExpiration": 86400 }, "lockStatus": "locked", "status": "enabled", diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 8d990d57d94..61fc38c87b8 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -62,7 +62,6 @@ featureAPI = <@> mkNamedAPI @'("get", OutlookCalIntegrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", OutlookCalIntegrationConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", MlsE2EIdConfig) (getFeatureStatus . DoAuth) - <@> mkNamedAPI @"put-MlsE2EIdConfig@v5" (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", MlsE2EIdConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @'("get", MlsMigrationConfig) (getFeatureStatus . DoAuth) <@> mkNamedAPI @'("put", MlsMigrationConfig) (setFeatureStatus . DoAuth) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 5aafab51168..d6b070c7f91 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -295,8 +295,6 @@ allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasT MlsE2EIdConfig (toGracePeriodOrDefault row.mlsE2eidGracePeriod) row.mlsE2eidAcmeDiscoverUrl - (error "TODO:(leif)") - (error "TODO:(leif)") where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 613d94632f3..dc8e82fe6ce 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -177,8 +177,7 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do fs ( -- FUTUREWORK: this block is duplicated in -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! - -- TODO(leif): implement the missing fields - MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl Nothing False + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl ) FeatureTTLUnlimited where From b0aedec2997c0681c0ce2617d4e0a4ef6b7461d1 Mon Sep 17 00:00:00 2001 From: Stefan Berthold Date: Fri, 17 May 2024 12:48:29 +0200 Subject: [PATCH 28/30] use JWK instead of bare keys as MLS removal keys (#3548) --- changelog.d/1-api-changes/WPB-484 | 1 + integration/integration.cabal | 1 + integration/test/Test/MLS.hs | 25 -------- integration/test/Test/MLS/Keys.hs | 60 +++++++++++++++++++ libs/types-common/src/Data/Json/Util.hs | 11 ++++ libs/wire-api/src/Wire/API/MLS/Keys.hs | 57 +++++++++++++++++- .../src/Wire/API/Routes/Public/Galley/MLS.hs | 12 +++- services/galley/src/Galley/API/MLS.hs | 15 ++++- services/galley/src/Galley/API/Public/MLS.hs | 3 +- 9 files changed, 154 insertions(+), 31 deletions(-) create mode 100644 changelog.d/1-api-changes/WPB-484 create mode 100644 integration/test/Test/MLS/Keys.hs diff --git a/changelog.d/1-api-changes/WPB-484 b/changelog.d/1-api-changes/WPB-484 new file mode 100644 index 00000000000..1ae7c36fe43 --- /dev/null +++ b/changelog.d/1-api-changes/WPB-484 @@ -0,0 +1 @@ +/mls/keys use JWK instead of bare keys as MLS removal keys diff --git a/integration/integration.cabal b/integration/integration.cabal index e9563261c78..15fd4c7a8d6 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -129,6 +129,7 @@ library Test.MessageTimer Test.MLS Test.MLS.KeyPackage + Test.MLS.Keys Test.MLS.Message Test.MLS.Notifications Test.MLS.One2One diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index dcf18eb99dc..b6df53ab4bb 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -4,7 +4,6 @@ module Test.MLS where import API.Brig (claimKeyPackages, deleteClient) import API.Galley -import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as Set @@ -747,27 +746,3 @@ testBackendRemoveProposal suite domain = do -- alice commits the external proposals r <- createPendingProposalCommit alice1 >>= sendAndConsumeCommitBundle shouldBeEmpty $ r %. "events" - -testPublicKeys :: HasCallStack => App () -testPublicKeys = do - alice <- randomUserId OwnDomain - let expectedKeys = - [ "ed25519", - "ecdsa_secp256r1_sha256", - "ecdsa_secp384r1_sha384", - "ecdsa_secp521r1_sha512" - ] - bindResponse (getMLSPublicKeys alice) $ \resp -> do - resp.status `shouldMatchInt` 200 - (KM.keys <$> asObject (resp.json %. "removal")) `shouldMatchSet` expectedKeys - -testPublicKeysMLSNotEnabled :: HasCallStack => App () -testPublicKeysMLSNotEnabled = withModifiedBackend - def - { galleyCfg = removeField "settings.mlsPrivateKeyPaths" - } - $ \domain -> do - alice <- randomUserId domain - bindResponse (getMLSPublicKeys alice) $ \resp -> do - resp.status `shouldMatchInt` 400 - resp.json %. "label" `shouldMatch` "mls-not-enabled" diff --git a/integration/test/Test/MLS/Keys.hs b/integration/test/Test/MLS/Keys.hs new file mode 100644 index 00000000000..64bba22e119 --- /dev/null +++ b/integration/test/Test/MLS/Keys.hs @@ -0,0 +1,60 @@ +module Test.MLS.Keys where + +import API.Galley +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as B8 +import SetupHelpers +import Testlib.Prelude + +testPublicKeys :: HasCallStack => App () +testPublicKeys = do + u <- randomUserId OwnDomain + keys <- getMLSPublicKeys u >>= getJSON 200 + + do + keys %. "removal.ed25519.crv" `shouldMatch` "Ed25519" + keys %. "removal.ed25519.kty" `shouldMatch` "OKP" + pubkeyS <- asString $ keys %. "removal.ed25519.x" + pubkey <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyS + B8.length pubkey `shouldMatchInt` 32 + + do + keys %. "removal.ecdsa_secp256r1_sha256.crv" `shouldMatch` "P-256" + keys %. "removal.ecdsa_secp256r1_sha256.kty" `shouldMatch` "EC" + pubkeyXS <- asString $ keys %. "removal.ecdsa_secp256r1_sha256.x" + pubkeyX <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyXS + B8.length pubkeyX `shouldMatchInt` 32 + pubkeyYS <- asString $ keys %. "removal.ecdsa_secp256r1_sha256.y" + pubkeyY <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyYS + B8.length pubkeyY `shouldMatchInt` 32 + + do + keys %. "removal.ecdsa_secp384r1_sha384.crv" `shouldMatch` "P-384" + keys %. "removal.ecdsa_secp384r1_sha384.kty" `shouldMatch` "EC" + pubkeyXS <- asString $ keys %. "removal.ecdsa_secp384r1_sha384.x" + pubkeyX <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyXS + B8.length pubkeyX `shouldMatchInt` 48 + pubkeyYS <- asString $ keys %. "removal.ecdsa_secp384r1_sha384.y" + pubkeyY <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyYS + B8.length pubkeyY `shouldMatchInt` 48 + + do + keys %. "removal.ecdsa_secp521r1_sha512.crv" `shouldMatch` "P-521" + keys %. "removal.ecdsa_secp521r1_sha512.kty" `shouldMatch` "EC" + pubkeyXS <- asString $ keys %. "removal.ecdsa_secp521r1_sha512.x" + pubkeyX <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyXS + B8.length pubkeyX `shouldMatchInt` 66 + pubkeyYS <- asString $ keys %. "removal.ecdsa_secp521r1_sha512.y" + pubkeyY <- assertOne . toList . B64U.decodeUnpadded $ B8.pack pubkeyYS + B8.length pubkeyY `shouldMatchInt` 66 + +testPublicKeysMLSNotEnabled :: HasCallStack => App () +testPublicKeysMLSNotEnabled = withModifiedBackend + def + { galleyCfg = removeField "settings.mlsPrivateKeyPaths" + } + $ \domain -> do + alice <- randomUserId domain + bindResponse (getMLSPublicKeys alice) $ \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "mls-not-enabled" diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 91f0e420fe6..87ac386a7c4 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -41,6 +41,7 @@ module Data.Json.Util -- * Base64 Base64ByteString (..), base64Schema, + base64URLSchema, Base64ByteStringL (..), base64SchemaL, fromBase64TextLenient, @@ -228,6 +229,16 @@ base64SchemaN = base64Schema :: ValueSchema SwaggerDoc ByteString base64Schema = unnamed base64SchemaN +base64URLSchemaN :: ValueSchema NamedSwaggerDoc ByteString +base64URLSchemaN = + ( (Text.decodeUtf8 . B64U.encodeUnpadded) + .= parsedText "Base64URLByteString" (B64U.decodeUnpadded . Text.encodeUtf8) + ) + & doc %~ fmap (S.schema . S.example ?~ A.String "ZXhhbXBsZQo=") + +base64URLSchema :: ValueSchema SwaggerDoc ByteString +base64URLSchema = unnamed base64URLSchemaN + -------------------------------------------------------------------------------- -- | Base64-encoded lazy 'ByteString'. diff --git a/libs/wire-api/src/Wire/API/MLS/Keys.hs b/libs/wire-api/src/Wire/API/MLS/Keys.hs index 28a49047332..92afc2df664 100644 --- a/libs/wire-api/src/Wire/API/MLS/Keys.hs +++ b/libs/wire-api/src/Wire/API/MLS/Keys.hs @@ -20,7 +20,8 @@ module Wire.API.MLS.Keys where import Crypto.ECC (Curve_P256R1, Curve_P384R1, Curve_P521R1) import Crypto.PubKey.ECDSA qualified as ECDSA import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.ByteArray +import Data.Bifunctor +import Data.ByteArray qualified as BA import Data.Json.Util import Data.OpenApi qualified as S import Data.Proxy @@ -76,8 +77,60 @@ instance ToSchema MLSPublicKey where mlsKeysToPublic :: MLSPrivateKeys -> MLSPublicKeys mlsKeysToPublic (MLSPrivateKeys (_, ed) (_, ec256) (_, ec384) (_, ec521)) = MLSKeys - { ed25519 = MLSPublicKey $ convert ed, + { ed25519 = MLSPublicKey $ BA.convert ed, ecdsa_secp256r1_sha256 = MLSPublicKey $ ECDSA.encodePublic (Proxy @Curve_P256R1) ec256, ecdsa_secp384r1_sha384 = MLSPublicKey $ ECDSA.encodePublic (Proxy @Curve_P384R1) ec384, ecdsa_secp521r1_sha512 = MLSPublicKey $ ECDSA.encodePublic (Proxy @Curve_P521R1) ec521 } + +data JWK = JWK + { keyType :: String, + curve :: String, + pubX :: ByteString, + pubY :: Maybe ByteString + } + deriving (Show, Ord, Eq) + +instance ToSchema JWK where + schema = + object "JWK" $ + JWK + <$> (.keyType) .= field "kty" schema + <*> (.curve) .= field "crv" schema + <*> (.pubX) .= field "x" base64URLSchema + <*> (.pubY) .= maybe_ (optField "y" base64URLSchema) + +type MLSPublicKeysJWK = MLSKeys JWK + +mlsKeysToPublicJWK :: + MLSPrivateKeys -> + Maybe MLSPublicKeysJWK +mlsKeysToPublicJWK (MLSPrivateKeys (_, ed) (_, ec256) (_, ec384) (_, ec521)) = + -- The kty parameter for ECDSA is "EC", for Ed25519 it's "OKP" (octet key + -- pair). + -- https://www.rfc-editor.org/rfc/rfc7518.html#section-6.1 + + -- The crv for P-256, P-384, and P-521 are their names. + -- https://www.rfc-editor.org/rfc/rfc7518.html#section-6.2.1.1 + + -- The x parameter is mandatory for all keys, the y parameter is mandatory for + -- all ECDSA keys. + -- https://www.rfc-editor.org/rfc/rfc7518.html#section-6.2.1 + MLSKeys (JWK "OKP" "Ed25519" (BA.convert ed) Nothing) + <$> (uncurry (JWK "EC" "P-256") . second Just <$> splitXY (ECDSA.encodePublic (Proxy @Curve_P256R1) ec256)) + <*> (uncurry (JWK "EC" "P-384") . second Just <$> splitXY (ECDSA.encodePublic (Proxy @Curve_P384R1) ec384)) + <*> (uncurry (JWK "EC" "P-521") . second Just <$> splitXY (ECDSA.encodePublic (Proxy @Curve_P521R1) ec521)) + where + -- Obtaining X and Y from an encoded curve point follows the logic of + -- Crypto.ECC's encodeECPoint and decodeECPoint (the module is not + -- exported). Points need to be encoded in uncompressed representation. This + -- is true for ECDSA.encodePublic. + -- https://www.rfc-editor.org/rfc/rfc8422#section-5.4.1 + splitXY mxy = do + (m, xy) <- BA.uncons mxy + -- The first Byte m is 4 for the uncompressed representation of curve points. + guard (m == 4) + -- The first half of the following Bytes belong to X and the second half + -- to Y. + let size = BA.length xy `div` 2 + pure $ BA.splitAt size xy diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index 1f4340bb372..6c53e5e3398 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -110,13 +110,23 @@ type MLSMessagingAPI = :> MultiVerb1 'POST '[JSON] (Respond 201 "Commit accepted and forwarded" MLSMessageSendingStatus) ) :<|> Named - "mls-public-keys" + "mls-public-keys-v5" ( Summary "Get public keys used by the backend to sign external proposals" :> From 'V5 + :> Until 'V6 :> CanThrow 'MLSNotEnabled :> "public-keys" :> ZLocalUser :> MultiVerb1 'GET '[JSON] (Respond 200 "Public keys" (MLSKeysByPurpose MLSPublicKeys)) ) + :<|> Named + "mls-public-keys" + ( Summary "Get public keys used by the backend to sign external proposals" + :> From 'V6 + :> CanThrow 'MLSNotEnabled + :> "public-keys" + :> ZLocalUser + :> MultiVerb1 'GET '[JSON] (Respond 200 "Public keys" (MLSKeysByPurpose MLSPublicKeysJWK)) + ) type MLSAPI = LiftNamed ("mls" :> MLSMessagingAPI) diff --git a/services/galley/src/Galley/API/MLS.hs b/services/galley/src/Galley/API/MLS.hs index 2b8c0b6fd67..ed2b2afbd17 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/services/galley/src/Galley/API/MLS.hs @@ -22,16 +22,19 @@ module Galley.API.MLS postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, getMLSPublicKeys, + getMLSPublicKeysJWK, ) where import Data.Id import Data.Qualified +import Galley.API.Error import Galley.API.MLS.Enabled import Galley.API.MLS.Message import Galley.Env import Imports import Polysemy +import Polysemy.Error import Polysemy.Input import Wire.API.Error import Wire.API.Error.Galley @@ -43,5 +46,13 @@ getMLSPublicKeys :: ) => Local UserId -> Sem r (MLSKeysByPurpose MLSPublicKeys) -getMLSPublicKeys _ = do - fmap mlsKeysToPublic <$> getMLSPrivateKeys +getMLSPublicKeys _ = mlsKeysToPublic <$$> getMLSPrivateKeys + +getMLSPublicKeysJWK :: + ( Member (Input Env) r, + Member (Error InternalError) r, + Member (ErrorS 'MLSNotEnabled) r + ) => + Local UserId -> + Sem r (MLSKeysByPurpose MLSPublicKeysJWK) +getMLSPublicKeysJWK _ = mapM (note (InternalErrorWithDescription "malformed MLS removal keys") . mlsKeysToPublicJWK) =<< getMLSPrivateKeys diff --git a/services/galley/src/Galley/API/Public/MLS.hs b/services/galley/src/Galley/API/Public/MLS.hs index fa05f9bf5d6..2391e44c081 100644 --- a/services/galley/src/Galley/API/Public/MLS.hs +++ b/services/galley/src/Galley/API/Public/MLS.hs @@ -27,4 +27,5 @@ mlsAPI :: API MLSAPI GalleyEffects mlsAPI = mkNamedAPI @"mls-message" (callsFed (exposeAnnotations postMLSMessageFromLocalUser)) <@> mkNamedAPI @"mls-commit-bundle" (callsFed (exposeAnnotations postMLSCommitBundleFromLocalUser)) - <@> mkNamedAPI @"mls-public-keys" getMLSPublicKeys + <@> mkNamedAPI @"mls-public-keys-v5" getMLSPublicKeys + <@> mkNamedAPI @"mls-public-keys" getMLSPublicKeysJWK From 2da83790a78548fd4751bec30658b224bbacc6b3 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 21 May 2024 14:05:03 +0200 Subject: [PATCH 29/30] [fix] elasticsearch reset on local db-reset (#4052) --- Makefile | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index f34ffcdb77a..40e8876bb52 100644 --- a/Makefile +++ b/Makefile @@ -297,13 +297,16 @@ db-reset: c ./dist/brig-index reset \ --elasticsearch-index-prefix directory \ --elasticsearch-server https://localhost:9200 \ + --elasticsearch-ca-cert ./services/brig/test/resources/elasticsearch-ca.pem \ --elasticsearch-credentials ./services/brig/test/resources/elasticsearch-credentials.yaml > /dev/null ./dist/brig-index reset \ --elasticsearch-index-prefix directory2 \ --elasticsearch-server https://localhost:9200 \ + --elasticsearch-ca-cert ./services/brig/test/resources/elasticsearch-ca.pem \ --elasticsearch-credentials ./services/brig/test/resources/elasticsearch-credentials.yaml > /dev/null ./integration/scripts/integration-dynamic-backends-brig-index.sh \ --elasticsearch-server https://localhost:9200 \ + --elasticsearch-ca-cert ./services/brig/test/resources/elasticsearch-ca.pem \ --elasticsearch-credentials ./services/brig/test/resources/elasticsearch-credentials.yaml > /dev/null @@ -565,8 +568,8 @@ helm-template-%: clean-charts charts-integration ./hack/bin/helm-template.sh $(*) # Ask the security team for the `DEPENDENCY_TRACK_API_KEY` (if you need it) -# changing the directory is necessary because of some quirkiness of how -# runhaskell / ghci behaves (it doesn't find modules that aren't in the same +# changing the directory is necessary because of some quirkiness of how +# runhaskell / ghci behaves (it doesn't find modules that aren't in the same # directory as the script that is being executed) .PHONY: upload-bombon upload-bombon: From a145bc1d6cd543b062fd9d82161c8a408e718f27 Mon Sep 17 00:00:00 2001 From: Zebot Date: Tue, 21 May 2024 12:44:13 +0000 Subject: [PATCH 30/30] Add changelog for Release 2024-05-21 --- CHANGELOG.md | 44 +++++++++++++++++++ changelog.d/1-api-changes/WPB-484 | 1 - changelog.d/1-api-changes/mls-ciphersuite | 1 - changelog.d/2-features/WPB-8988 | 1 - changelog.d/2-features/delete-voip-tokens | 1 - changelog.d/3-bug-fixes/gundeck-arn-parsing | 1 - changelog.d/3-bug-fixes/mixed-ciphersuite | 1 - changelog.d/5-internal/WPB-8702 | 1 - changelog.d/5-internal/federator-request-id | 1 - changelog.d/5-internal/mls-test-cli-update | 1 - changelog.d/5-internal/remove-inbucket | 1 - .../5-internal/servantify-galley-internal | 1 - .../5-internal/wpb-5990-begin-user-subsystem | 1 - ...28-clean-up-syntax-of-tests-from-bsi-audit | 1 - 14 files changed, 44 insertions(+), 13 deletions(-) delete mode 100644 changelog.d/1-api-changes/WPB-484 delete mode 100644 changelog.d/1-api-changes/mls-ciphersuite delete mode 100644 changelog.d/2-features/WPB-8988 delete mode 100644 changelog.d/2-features/delete-voip-tokens delete mode 100644 changelog.d/3-bug-fixes/gundeck-arn-parsing delete mode 100644 changelog.d/3-bug-fixes/mixed-ciphersuite delete mode 100644 changelog.d/5-internal/WPB-8702 delete mode 100644 changelog.d/5-internal/federator-request-id delete mode 100644 changelog.d/5-internal/mls-test-cli-update delete mode 100644 changelog.d/5-internal/remove-inbucket delete mode 100644 changelog.d/5-internal/servantify-galley-internal delete mode 100644 changelog.d/5-internal/wpb-5990-begin-user-subsystem delete mode 100644 changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit diff --git a/CHANGELOG.md b/CHANGELOG.md index 879e2cdacb9..b5b8da28b1a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,47 @@ +# [2024-05-21] (Chart Release 5.3.0) + +## API changes + + +* /mls/keys use JWK instead of bare keys as MLS removal keys (#3548) + +* The `cipher_suite` field is not present anymore in objects corresponding to newly created conversations (#4009) + + +## Features + + +* Upgrade `rusty-jwt-tools` to support `ecdsa_secp256r1_sha256` (#4035) + +* gundeck: Delete all APNS_VOIP and APNS_VOIP_SANDBOX push tokens (#4044) + + +## Bug fixes and other updates + + +* gundeck: Fix parsing errors for SNS ARN for VOIP Tokens (#4040) + +* Fix hardcoded ciphersuite when switching to mixed (#4048) + + +## Internal changes + + +* Add tool to determine number of phone-only users (#4024) + +* Log federator request ID on exceptions (#4037) + +* Update mls-test-cli to version 0.12 (#4039) + +* Remove inbucket helm chart. (#4032) + +* Finish servantifying galley and remove wai-routing dependency (#4018) + +* New subsystem for user management. (#3977) + +* Clean up syntax of test cases that occur in BSI audit. (#4041) + + # [2024-04-26] (Chart Release 4.43.0) ## Bug fixes and other updates diff --git a/changelog.d/1-api-changes/WPB-484 b/changelog.d/1-api-changes/WPB-484 deleted file mode 100644 index 1ae7c36fe43..00000000000 --- a/changelog.d/1-api-changes/WPB-484 +++ /dev/null @@ -1 +0,0 @@ -/mls/keys use JWK instead of bare keys as MLS removal keys diff --git a/changelog.d/1-api-changes/mls-ciphersuite b/changelog.d/1-api-changes/mls-ciphersuite deleted file mode 100644 index 4d24c2f0060..00000000000 --- a/changelog.d/1-api-changes/mls-ciphersuite +++ /dev/null @@ -1 +0,0 @@ -The `cipher_suite` field is not present anymore in objects corresponding to newly created conversations diff --git a/changelog.d/2-features/WPB-8988 b/changelog.d/2-features/WPB-8988 deleted file mode 100644 index fa19b506056..00000000000 --- a/changelog.d/2-features/WPB-8988 +++ /dev/null @@ -1 +0,0 @@ -Upgrade `rusty-jwt-tools` to support `ecdsa_secp256r1_sha256` diff --git a/changelog.d/2-features/delete-voip-tokens b/changelog.d/2-features/delete-voip-tokens deleted file mode 100644 index 3014514221c..00000000000 --- a/changelog.d/2-features/delete-voip-tokens +++ /dev/null @@ -1 +0,0 @@ -gundeck: Delete all APNS_VOIP and APNS_VOIP_SANDBOX push tokens diff --git a/changelog.d/3-bug-fixes/gundeck-arn-parsing b/changelog.d/3-bug-fixes/gundeck-arn-parsing deleted file mode 100644 index 31a489112a0..00000000000 --- a/changelog.d/3-bug-fixes/gundeck-arn-parsing +++ /dev/null @@ -1 +0,0 @@ -gundeck: Fix parsing errors for SNS ARN for VOIP Tokens diff --git a/changelog.d/3-bug-fixes/mixed-ciphersuite b/changelog.d/3-bug-fixes/mixed-ciphersuite deleted file mode 100644 index cdc337dd74b..00000000000 --- a/changelog.d/3-bug-fixes/mixed-ciphersuite +++ /dev/null @@ -1 +0,0 @@ -Fix hardcoded ciphersuite when switching to mixed diff --git a/changelog.d/5-internal/WPB-8702 b/changelog.d/5-internal/WPB-8702 deleted file mode 100644 index 442ee8a831a..00000000000 --- a/changelog.d/5-internal/WPB-8702 +++ /dev/null @@ -1 +0,0 @@ -Add tool to determine number of phone-only users diff --git a/changelog.d/5-internal/federator-request-id b/changelog.d/5-internal/federator-request-id deleted file mode 100644 index 4f8c042bfa8..00000000000 --- a/changelog.d/5-internal/federator-request-id +++ /dev/null @@ -1 +0,0 @@ -Log federator request ID on exceptions diff --git a/changelog.d/5-internal/mls-test-cli-update b/changelog.d/5-internal/mls-test-cli-update deleted file mode 100644 index 851866f6469..00000000000 --- a/changelog.d/5-internal/mls-test-cli-update +++ /dev/null @@ -1 +0,0 @@ -Update mls-test-cli to version 0.12 diff --git a/changelog.d/5-internal/remove-inbucket b/changelog.d/5-internal/remove-inbucket deleted file mode 100644 index d4a77b0fc3d..00000000000 --- a/changelog.d/5-internal/remove-inbucket +++ /dev/null @@ -1 +0,0 @@ -Remove inbucket helm chart. diff --git a/changelog.d/5-internal/servantify-galley-internal b/changelog.d/5-internal/servantify-galley-internal deleted file mode 100644 index a5fb9fed313..00000000000 --- a/changelog.d/5-internal/servantify-galley-internal +++ /dev/null @@ -1 +0,0 @@ -Finish servantifying galley and remove wai-routing dependency diff --git a/changelog.d/5-internal/wpb-5990-begin-user-subsystem b/changelog.d/5-internal/wpb-5990-begin-user-subsystem deleted file mode 100644 index d74501002ea..00000000000 --- a/changelog.d/5-internal/wpb-5990-begin-user-subsystem +++ /dev/null @@ -1 +0,0 @@ -New subsystem for user management. \ No newline at end of file diff --git a/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit b/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit deleted file mode 100644 index 63c5cb9df02..00000000000 --- a/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit +++ /dev/null @@ -1 +0,0 @@ -Clean up syntax of test cases that occur in BSI audit. \ No newline at end of file