From d2aa2053bd1576522f452d1dfca5e4108095e4ca Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 17 Oct 2022 18:38:46 +0200 Subject: [PATCH 01/14] CommitBundle: Add protobuf ser/deser --- libs/wire-api/src/Wire/API/ConverProtoLens.hs | 31 +++++ .../wire-api/src/Wire/API/MLS/CommitBundle.hs | 41 ++++++ .../src/Wire/API/MLS/GroupInfoBundle.hs | 56 ++++++-- libs/wire-api/test/unit/Test/Wire/API/MLS.hs | 2 +- .../test/unit/Test/Wire/API/Roundtrip/MLS.hs | 123 +++++++++++++++--- libs/wire-api/wire-api.cabal | 1 + .../generic-message-proto | 2 +- .../wire-message-proto-lens.cabal | 5 +- 8 files changed, 229 insertions(+), 32 deletions(-) create mode 100644 libs/wire-api/src/Wire/API/ConverProtoLens.hs diff --git a/libs/wire-api/src/Wire/API/ConverProtoLens.hs b/libs/wire-api/src/Wire/API/ConverProtoLens.hs new file mode 100644 index 0000000000..60a5e9568d --- /dev/null +++ b/libs/wire-api/src/Wire/API/ConverProtoLens.hs @@ -0,0 +1,31 @@ +-- 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.API.ConverProtoLens where + +import Data.Bifunctor (Bifunctor (first)) +import Imports + +-- | This typeclass exists to provide overloaded function names for convertion +-- between data types generated by proto-lens and data types used in wire +class ConvertProtoLens a b where + fromProtolens :: a -> Either Text b + toProtolens :: b -> a + +-- | Add labels to error messages +label :: Text -> Either Text a -> Either Text a +label lbl = first ((lbl <> ": ") <>) diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index 67ebd6fd5d..739ed625d5 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -17,8 +17,18 @@ module Wire.API.MLS.CommitBundle where +import Control.Lens (view, (.~)) +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import Data.ProtoLens (decodeMessage, encodeMessage) +import qualified Data.ProtoLens (Message (defMessage)) import qualified Data.Swagger as S +import qualified Data.Text as T import Imports +import qualified Proto.Mls +import qualified Proto.Mls_Fields as Proto.Mls +import Wire.API.ConverProtoLens +import qualified Wire.API.ConverProtoLens as CP import Wire.API.MLS.GroupInfoBundle import Wire.API.MLS.Message import Wire.API.MLS.Serialisation @@ -31,14 +41,45 @@ data CommitBundle = CommitBundle } deriving (Eq, Show) +instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where + fromProtolens protoBundle = CP.label "CommitBundle" $ do + CommitBundle + <$> CP.label "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) + <*> CP.label + "welcome" + ( let bs = view Proto.Mls.welcome protoBundle + in if BS.length bs == 0 + then pure Nothing + else Just <$> decodeMLS' bs + ) + <*> CP.label "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) + toProtolens bundle = + let commitData = rmRaw (cbCommitMsg bundle) + welcomeData = maybe mempty rmRaw (cbWelcome bundle) + groupInfoData = toProtolens (cbGroupInfoBundle bundle) + in ( Data.ProtoLens.defMessage + & Proto.Mls.commit .~ commitData + & Proto.Mls.welcome .~ welcomeData + & Proto.Mls.groupInfoBundle .~ groupInfoData + ) + instance ParseMLS CommitBundle where parseMLS = CommitBundle <$> parseMLS <*> parseMLSOptional parseMLS <*> parseMLS instance S.ToSchema CommitBundle where declareNamedSchema _ = pure (mlsSwagger "CommitBundle") +-- TODO: remove this instance SerialiseMLS CommitBundle where serialiseMLS (CommitBundle commit welcome gi) = do serialiseMLS commit serialiseMLSOptional serialiseMLS welcome serialiseMLS gi + +deserializeCommitBundle :: ByteString -> Either Text CommitBundle +deserializeCommitBundle b = do + protoCommitBundle :: Proto.Mls.CommitBundle <- first (("Parsing protobuf failed: " <>) . T.pack) (decodeMessage b) + first ("Converting from protobuf failed: " <>) (fromProtolens protoCommitBundle) + +serializeCommitBundle :: CommitBundle -> ByteString +serializeCommitBundle = encodeMessage . (toProtolens @Proto.Mls.CommitBundle @CommitBundle) diff --git a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs index 57acb31499..78aac8487a 100644 --- a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs @@ -17,27 +17,67 @@ module Wire.API.MLS.GroupInfoBundle where +import Control.Lens (view, (.~)) +import Data.ProtoLens (Message (defMessage)) import Imports +import qualified Proto.Mls +import qualified Proto.Mls_Fields as Proto.Mls import Test.QuickCheck +import Wire.API.ConverProtoLens +import qualified Wire.API.ConverProtoLens as CP import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation import Wire.Arbitrary -data GroupInfoEncryption = UnencryptedGroupInfo | JweEncryptedGroupInfo - deriving stock (Eq, Show, Generic, Bounded, Enum) - deriving (Arbitrary) via (GenericUniform GroupInfoEncryption) +data GroupInfoType = GroupInfoTypePublicGroupState | UnencryptedGroupInfo | JweEncryptedGroupInfo + deriving stock (Eq, Show, Generic, Enum, Bounded) + deriving (Arbitrary) via (GenericUniform GroupInfoType) + +instance ConvertProtoLens Proto.Mls.GroupInfoType GroupInfoType where + fromProtolens Proto.Mls.PUBLIC_GROUP_STATE = pure GroupInfoTypePublicGroupState + fromProtolens Proto.Mls.GROUP_INFO = pure UnencryptedGroupInfo + fromProtolens Proto.Mls.GROUP_INFO_JWE = pure JweEncryptedGroupInfo + + toProtolens GroupInfoTypePublicGroupState = Proto.Mls.PUBLIC_GROUP_STATE + toProtolens UnencryptedGroupInfo = Proto.Mls.GROUP_INFO + toProtolens JweEncryptedGroupInfo = Proto.Mls.GROUP_INFO_JWE -data GroupInfoTreeType = TreeFull | TreeDelta | TreeByRef +data RatchetTreeType = TreeFull | TreeDelta | TreeByRef deriving stock (Eq, Show, Generic, Bounded, Enum) - deriving (Arbitrary) via (GenericUniform GroupInfoTreeType) + deriving (Arbitrary) via (GenericUniform RatchetTreeType) + +instance ConvertProtoLens Proto.Mls.RatchetTreeType RatchetTreeType where + fromProtolens Proto.Mls.FULL = pure TreeFull + fromProtolens Proto.Mls.DELTA = pure TreeDelta + fromProtolens Proto.Mls.REFERENCE = pure TreeByRef + + toProtolens TreeFull = Proto.Mls.FULL + toProtolens TreeDelta = Proto.Mls.DELTA + toProtolens TreeByRef = Proto.Mls.REFERENCE data GroupInfoBundle = GroupInfoBundle - { gipEncryptionType :: GroupInfoEncryption, - gipTreeType :: GroupInfoTreeType, + { gipGroupInfoType :: GroupInfoType, + gipRatchetTreeType :: RatchetTreeType, gipGroupState :: RawMLS PublicGroupState } deriving stock (Eq, Show, Generic) +instance ConvertProtoLens Proto.Mls.GroupInfoBundle GroupInfoBundle where + fromProtolens protoBundle = + CP.label "GroupInfoBundle" $ + GroupInfoBundle + <$> CP.label "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) + <*> CP.label "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) + <*> CP.label "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) + toProtolens bundle = + let encryptionType = toProtolens (gipGroupInfoType bundle) + treeType = toProtolens (gipRatchetTreeType bundle) + in ( defMessage + & Proto.Mls.groupInfoType .~ encryptionType + & Proto.Mls.ratchetTreeType .~ treeType + & Proto.Mls.groupInfo .~ rmRaw (gipGroupState bundle) + ) + instance Arbitrary GroupInfoBundle where arbitrary = GroupInfoBundle @@ -48,7 +88,7 @@ instance Arbitrary GroupInfoBundle where instance ParseMLS GroupInfoBundle where parseMLS = GroupInfoBundle - <$> parseMLSEnum @Word8 "GroupInfoEncryptionEnum" + <$> parseMLSEnum @Word8 "GroupInfoTypeEnum" <*> parseMLSEnum @Word8 "RatchetTreeEnum" <*> parseMLS diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs index 7be804c918..62d403c65a 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -62,7 +62,7 @@ tests = testCase "key package ref" testKeyPackageRef, testCase "validate message signature" testVerifyMLSPlainTextWithKey, testCase "create signed remove proposal" testRemoveProposalMessageSignature, - testCase "parse GroupInfoBundle" testParseGroupInfoBundle + testCase "parse GroupInfoBundle" testParseGroupInfoBundle -- TODO: remove this also ] testParseKeyPackage :: IO () diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs index c64845a252..d73620945b 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/MLS.hs @@ -21,10 +21,14 @@ module Test.Wire.API.Roundtrip.MLS (tests) where import Data.Binary.Put import Imports +import qualified Proto.Mls import qualified Test.Tasty as T import Test.Tasty.QuickCheck import Type.Reflection (typeRep) +import Wire.API.ConverProtoLens +import Wire.API.MLS.CommitBundle import Wire.API.MLS.Extension +import Wire.API.MLS.GroupInfoBundle import Wire.API.MLS.KeyPackage import Wire.API.MLS.Message import Wire.API.MLS.Proposal @@ -36,7 +40,7 @@ tests :: T.TestTree tests = T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "MLS roundtrip tests" $ [ testRoundTrip @KeyPackageRef, - testRoundTrip @RemoveProposalSender, + testRoundTrip @TestPreconfiguredSender, testRoundTrip @RemoveProposalMessage, testRoundTrip @RemoveProposalPayload, testRoundTrip @AppAckProposalTest, @@ -44,7 +48,9 @@ tests = testRoundTrip @PublicGroupStateTBS, testRoundTrip @PublicGroupState, testRoundTrip @Welcome, - testRoundTrip @OpaquePublicGroupState + testRoundTrip @OpaquePublicGroupState, + testConvertProtoRoundTrip @Proto.Mls.GroupInfoBundle @GroupInfoBundle, + testConvertProtoRoundTrip @Proto.Mls.CommitBundle @TestCommitBundle ] testRoundTrip :: @@ -58,30 +64,72 @@ testRoundTrip = testProperty msg trip counterexample (show (runPut (serialiseMLS v))) $ Right v === (decodeMLS . runPut . serialiseMLS) v +testConvertProtoRoundTrip :: + forall p a. + ( Arbitrary a, + Typeable a, + Show a, + Show p, + Eq a, + ConvertProtoLens p a + ) => + T.TestTree +testConvertProtoRoundTrip = testProperty (show (typeRep @a)) trip + where + trip (v :: a) = + counterexample (show (toProtolens @p @a v)) $ + Right v === do + let pa = toProtolens @p @a v + fromProtolens @p @a pa + -------------------------------------------------------------------------------- -- auxiliary types -newtype RemoveProposalMessage = RemoveProposalMessage (Message 'MLSPlainText) - deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) +class ArbitrarySender a where + arbitrarySender :: Gen (Sender 'MLSPlainText) -newtype RemoveProposalTBS = RemoveProposalTBS (MessageTBS 'MLSPlainText) +class ArbitraryMessagePayload a where + arbitraryMessagePayload :: Gen (MessagePayload 'MLSPlainText) + +class ArbitraryMessageTBS a where + arbitraryArbitraryMessageTBS :: Gen (MessageTBS 'MLSPlainText) + +newtype MessageGenerator tbs = MessageGenerator {unMessageGenerator :: Message 'MLSPlainText} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) -instance Arbitrary RemoveProposalTBS where - arbitrary = - fmap RemoveProposalTBS $ - MessageTBS KnownFormatTag - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> (unRemoveProposalSender <$> arbitrary) - <*> (unRemoveProposalPayload <$> arbitrary) +instance (ArbitraryMessageTBS tbs) => Arbitrary (MessageGenerator tbs) where + arbitrary = do + tbs <- arbitraryArbitraryMessageTBS @tbs + MessageGenerator + <$> (Message (mkRawMLS tbs) <$> arbitrary) + +data MessageTBSGenerator sender payload + +instance + ( ArbitrarySender sender, + ArbitraryMessagePayload payload + ) => + ArbitraryMessageTBS (MessageTBSGenerator sender payload) + where + arbitraryArbitraryMessageTBS = + MessageTBS KnownFormatTag + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrarySender @sender + <*> arbitraryMessagePayload @payload + +--- + +newtype RemoveProposalMessage = RemoveProposalMessage {unRemoveProposalMessage :: Message 'MLSPlainText} + deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) instance Arbitrary RemoveProposalMessage where - arbitrary = do - RemoveProposalTBS tbs <- arbitrary + arbitrary = RemoveProposalMessage - <$> (Message (mkRawMLS tbs) <$> arbitrary) + <$> (unMessageGenerator <$> arbitrary @(MessageGenerator (MessageTBSGenerator TestPreconfiguredSender RemoveProposalPayload))) + +--- newtype RemoveProposalPayload = RemoveProposalPayload {unRemoveProposalPayload :: MessagePayload 'MLSPlainText} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) @@ -89,12 +137,22 @@ newtype RemoveProposalPayload = RemoveProposalPayload {unRemoveProposalPayload : instance Arbitrary RemoveProposalPayload where arbitrary = RemoveProposalPayload . ProposalMessage . mkRemoveProposal <$> arbitrary -newtype RemoveProposalSender = RemoveProposalSender - {unRemoveProposalSender :: Sender 'MLSPlainText} +instance ArbitraryMessagePayload RemoveProposalPayload where + arbitraryMessagePayload = unRemoveProposalPayload <$> arbitrary + +--- + +newtype TestPreconfiguredSender = TestPreconfiguredSender + {unTestPreconfiguredSender :: Sender 'MLSPlainText} deriving newtype (ParseMLS, SerialiseMLS, Eq, Show) -instance Arbitrary RemoveProposalSender where - arbitrary = RemoveProposalSender . PreconfiguredSender <$> arbitrary +instance Arbitrary TestPreconfiguredSender where + arbitrary = TestPreconfiguredSender . PreconfiguredSender <$> arbitrary + +instance ArbitrarySender TestPreconfiguredSender where + arbitrarySender = unTestPreconfiguredSender <$> arbitrary + +--- newtype AppAckProposalTest = AppAckProposalTest Proposal deriving newtype (ParseMLS, Eq, Show) @@ -106,6 +164,8 @@ instance SerialiseMLS AppAckProposalTest where serialiseMLS (AppAckProposalTest (AppAckProposal mrs)) = serialiseAppAckProposal mrs serialiseMLS _ = serialiseAppAckProposal [] +--- + newtype ExtensionVector = ExtensionVector [Extension] deriving newtype (Arbitrary, Eq, Show) @@ -115,3 +175,24 @@ instance ParseMLS ExtensionVector where instance SerialiseMLS ExtensionVector where serialiseMLS (ExtensionVector exts) = do serialiseMLSVector @Word32 serialiseMLS exts + +--- + +newtype TestCommitBundle = TestCommitBundle {unTestCommitBundle :: CommitBundle} + deriving (Show, Eq) + +-- | The commit bundle should contain a commit message, not a remove proposal +-- message. However defining MLS serialization for Commits and all nested types +-- seems overkill to test the commit bundle roundtrip +instance Arbitrary TestCommitBundle where + arbitrary = do + bundle <- + CommitBundle + <$> (mkRawMLS . unRemoveProposalMessage <$> arbitrary) + <*> oneof [Just <$> (mkRawMLS <$> arbitrary), pure Nothing] + <*> arbitrary + pure (TestCommitBundle bundle) + +instance ConvertProtoLens Proto.Mls.CommitBundle TestCommitBundle where + fromProtolens = fmap TestCommitBundle . fromProtolens @Proto.Mls.CommitBundle @CommitBundle + toProtolens = toProtolens . unTestCommitBundle diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 126ac7d697..458195ddd1 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -16,6 +16,7 @@ library Wire.API.Asset Wire.API.Call.Config Wire.API.Connection + Wire.API.ConverProtoLens Wire.API.Conversation Wire.API.Conversation.Action Wire.API.Conversation.Action.Tag diff --git a/libs/wire-message-proto-lens/generic-message-proto b/libs/wire-message-proto-lens/generic-message-proto index 7a9fdf8a93..08e002cae5 160000 --- a/libs/wire-message-proto-lens/generic-message-proto +++ b/libs/wire-message-proto-lens/generic-message-proto @@ -1 +1 @@ -Subproject commit 7a9fdf8a93db4093dcdb07e417c089cd2ac8b866 +Subproject commit 08e002cae560b0a588feee9f7d31929f9e658820 diff --git a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal index 4afca0f063..3f49049fac 100644 --- a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal +++ b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal @@ -9,7 +9,8 @@ maintainer: Wire Swiss GmbH copyright: (c) 2021 Wire Swiss GmbH license: AGPL-3 build-type: Custom -extra-source-files: generic-message-proto/proto/otr.proto +extra-source-files: generic-message-proto/proto/otr.proto + , generic-message-proto/proto/mls.proto custom-setup setup-depends: @@ -21,6 +22,8 @@ library exposed-modules: Proto.Otr Proto.Otr_Fields + Proto.Mls + Proto.Mls_Fields other-modules: Paths_wire_message_proto_lens hs-source-dirs: ./. From 018e934466bf4fc6c25f3f46a47895da686509f6 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 18 Oct 2022 13:39:25 +0200 Subject: [PATCH 02/14] Change mime type of endpoint --- .../wire-api/src/Wire/API/MLS/CommitBundle.hs | 19 +++++++------------ .../src/Wire/API/MLS/PublicGroupState.hs | 5 ----- libs/wire-api/src/Wire/API/MLS/Servant.hs | 19 ++++++++++++++++++- .../src/Wire/API/Routes/Public/Galley.hs | 2 +- services/galley/src/Galley/API/Federation.hs | 4 ++-- services/galley/src/Galley/API/MLS/Message.hs | 12 ++++++------ 6 files changed, 34 insertions(+), 27 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index 739ed625d5..bc5783dccf 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -17,7 +17,7 @@ module Wire.API.MLS.CommitBundle where -import Control.Lens (view, (.~)) +import Control.Lens (view, (.~), (?~)) import Data.Bifunctor (first) import qualified Data.ByteString as BS import Data.ProtoLens (decodeMessage, encodeMessage) @@ -63,18 +63,13 @@ instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where & Proto.Mls.groupInfoBundle .~ groupInfoData ) -instance ParseMLS CommitBundle where - parseMLS = CommitBundle <$> parseMLS <*> parseMLSOptional parseMLS <*> parseMLS - instance S.ToSchema CommitBundle where - declareNamedSchema _ = pure (mlsSwagger "CommitBundle") - --- TODO: remove this -instance SerialiseMLS CommitBundle where - serialiseMLS (CommitBundle commit welcome gi) = do - serialiseMLS commit - serialiseMLSOptional serialiseMLS welcome - serialiseMLS gi + declareNamedSchema _ = + pure $ + S.NamedSchema (Just "CommitBundle") $ + mempty + & S.description + ?~ "A protobuf-serialized object. See wireapp/generic-message-proto for the definition." deserializeCommitBundle :: ByteString -> Either Text CommitBundle deserializeCommitBundle b = do diff --git a/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs b/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs index d590260157..38772d5b00 100644 --- a/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs +++ b/libs/wire-api/src/Wire/API/MLS/PublicGroupState.hs @@ -24,7 +24,6 @@ import Data.Binary.Put import qualified Data.ByteString.Lazy as LBS import qualified Data.Swagger as S import Imports -import Servant.API.ContentTypes import Test.QuickCheck hiding (label) import Wire.API.MLS.CipherSuite import Wire.API.MLS.Epoch @@ -32,7 +31,6 @@ import Wire.API.MLS.Extension import Wire.API.MLS.Group import Wire.API.MLS.KeyPackage import Wire.API.MLS.Serialisation -import Wire.API.MLS.Servant import Wire.Arbitrary data PublicGroupStateTBS = PublicGroupStateTBS @@ -102,9 +100,6 @@ instance SerialiseMLS OpaquePublicGroupState where instance S.ToSchema OpaquePublicGroupState where declareNamedSchema _ = pure (mlsSwagger "OpaquePublicGroupState") -instance MimeRender MLS OpaquePublicGroupState where - mimeRender _ = LBS.fromStrict . unOpaquePublicGroupState - toOpaquePublicGroupState :: RawMLS PublicGroupState -> OpaquePublicGroupState toOpaquePublicGroupState = OpaquePublicGroupState . rmRaw diff --git a/libs/wire-api/src/Wire/API/MLS/Servant.hs b/libs/wire-api/src/Wire/API/MLS/Servant.hs index 1f4ffb6c59..b735e8e1a8 100644 --- a/libs/wire-api/src/Wire/API/MLS/Servant.hs +++ b/libs/wire-api/src/Wire/API/MLS/Servant.hs @@ -15,14 +15,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.MLS.Servant (MLS, mimeUnrenderMLSWith) where +module Wire.API.MLS.Servant (MLS, mimeUnrenderMLSWith, CommitBundleMimeType) where import Data.Bifunctor import Data.Binary +import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import Imports import Network.HTTP.Media ((//)) import Servant.API hiding (Get) +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.PublicGroupState (OpaquePublicGroupState, unOpaquePublicGroupState) import Wire.API.MLS.Serialisation data MLS @@ -33,5 +36,19 @@ instance Accept MLS where instance {-# OVERLAPPABLE #-} ParseMLS a => MimeUnrender MLS a where mimeUnrender _ = mimeUnrenderMLSWith parseMLS +instance MimeRender MLS OpaquePublicGroupState where + mimeRender _ = LBS.fromStrict . unOpaquePublicGroupState + mimeUnrenderMLSWith :: Get a -> LByteString -> Either String a mimeUnrenderMLSWith p = first T.unpack . decodeMLSWith p + +data CommitBundleMimeType + +instance Accept CommitBundleMimeType where + contentType _ = "application" // "vnd.wire.commit-bundle" + +instance MimeUnrender CommitBundleMimeType CommitBundle where + mimeUnrender _ = first T.unpack . deserializeCommitBundle . LBS.toStrict + +instance MimeRender CommitBundleMimeType CommitBundle where + mimeRender _ = LBS.fromStrict . serializeCommitBundle diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 952e8cd22d..50df785b63 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -1427,7 +1427,7 @@ type MLSMessagingAPI = :> CanThrow MLSProposalFailure :> "commit-bundles" :> ZConn - :> ReqBody '[MLS] (RawMLS CommitBundle) + :> ReqBody '[CommitBundleMimeType] CommitBundle :> MultiVerb1 'POST '[JSON] (Respond 201 "Commit accepted and forwarded" MLSMessageSendingStatus) ) :<|> Named diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 46e56f2fe6..0a109d3917 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -630,9 +630,9 @@ sendMLSCommitBundle remoteDomain msr = $ do loc <- qualifyLocal () let sender = toRemoteUnsafe remoteDomain (F.msrSender msr) - bundle <- either (throw . mlsProtocolError) pure $ decodeMLS' (fromBase64ByteString (F.msrRawMessage msr)) + bundle <- either (throw . mlsProtocolError) pure $ deserializeCommitBundle (fromBase64ByteString (F.msrRawMessage msr)) mapToGalleyError @MLSBundleStaticErrors $ do - let msg = rmValue (cbCommitMsg (rmValue bundle)) + let msg = rmValue (cbCommitMsg bundle) qcnv <- E.getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound when (qUnqualified qcnv /= F.msrConvId msr) $ throwS @'MLSGroupConversationMismatch F.MLSMessageResponseUpdates . map lcuUpdate diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 0ed1e39ca1..bda3e0344a 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -200,12 +200,12 @@ postMLSCommitBundle :: Qualified UserId -> Qualified ConvId -> Maybe ConnId -> - RawMLS CommitBundle -> + CommitBundle -> Sem r [LocalConversationUpdate] postMLSCommitBundle loc qusr qcnv conn rawBundle = foldQualified loc - (postMLSCommitBundleToLocalConv qusr conn (rmValue rawBundle)) + (postMLSCommitBundleToLocalConv qusr conn rawBundle) (postMLSCommitBundleToRemoteConv loc qusr conn rawBundle) qcnv @@ -228,10 +228,10 @@ postMLSCommitBundleFromLocalUser :: ) => Local UserId -> ConnId -> - RawMLS CommitBundle -> + CommitBundle -> Sem r MLSMessageSendingStatus postMLSCommitBundleFromLocalUser lusr conn bundle = do - let msg = rmValue (cbCommitMsg (rmValue bundle)) + let msg = rmValue (cbCommitMsg bundle) qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound events <- map lcuEvent @@ -320,7 +320,7 @@ postMLSCommitBundleToRemoteConv :: Local x -> Qualified UserId -> Maybe ConnId -> - RawMLS CommitBundle -> + CommitBundle -> Remote ConvId -> Sem r [LocalConversationUpdate] postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do @@ -335,7 +335,7 @@ postMLSCommitBundleToRemoteConv loc qusr con bundle rcnv = do MessageSendRequest { msrConvId = tUnqualified rcnv, msrSender = tUnqualified lusr, - msrRawMessage = Base64ByteString (rmRaw bundle) + msrRawMessage = Base64ByteString (serializeCommitBundle bundle) } updates <- case resp of MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e From dfab6aa91a3d54516dcd110d8f8c48edd0827bcd Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 11:14:41 +0200 Subject: [PATCH 03/14] Adapt tests --- services/galley/test/integration/API/MLS/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index bd4b5b368c..bc24cd4716 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -136,7 +136,7 @@ postCommitBundle sender bundle = do ( galley . paths ["mls", "commit-bundles"] . zUser sender . zConn "conn" - . content "message/mls" + . content "application/vnd.wire.commit-bundle" . bytes bundle ) @@ -806,7 +806,7 @@ createBundle mp = do bundle <- either (liftIO . assertFailure . T.unpack) pure $ mkBundle mp - pure (encodeMLS' bundle) + pure (serializeCommitBundle bundle) sendAndConsumeCommitBundle :: HasCallStack => From 3dc927923fbb9c8a321ba9401af8bd492b03ef87 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 12:48:11 +0200 Subject: [PATCH 04/14] Remove superfluous test --- services/galley/test/integration/API/MLS.hs | 47 --------------------- 1 file changed, 47 deletions(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index f5273fd39a..2de4c1e34d 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -105,7 +105,6 @@ tests s = test s "add user with some non-MLS clients" testAddUserWithProteusClients, test s "send a stale commit" testStaleCommit, test s "add remote user to a conversation" testAddRemoteUser, - test s "add remote user with a commit bundle" testAddRemoteUserWithBundle, test s "return error when commit is locked" testCommitLock, test s "add user to a conversation with proposal + commit" testAddUserBareProposalCommit, test s "post commit that references a unknown proposal" testUnknownProposalRefCommit, @@ -635,52 +634,6 @@ testAddRemoteUser = do event <- assertOne events assertJoinEvent qcnv alice [bob] roleNameWireMember event -testAddRemoteUserWithBundle :: TestM () -testAddRemoteUserWithBundle = do - users@[alice, bob] <- createAndConnectUsers [Nothing, Just "bob.example.com"] - (events, reqs, qcnv) <- runMLSTest $ do - [alice1, bob1] <- traverse createMLSClient users - (_, qcnv) <- setupMLSGroup alice1 - - let mock req = case frRPC req of - "on-conversation-updated" -> pure (Aeson.encode ()) - "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) - "get-mls-clients" -> - pure - . Aeson.encode - . Set.fromList - . map (flip ClientInfo True . ciClient) - $ [bob1] - "mls-welcome" -> pure (Aeson.encode EmptyResponse) - ms -> assertFailure ("unmocked endpoint called: " <> cs ms) - - commit <- createAddCommit alice1 [bob] - (events, reqs) <- - withTempMockFederator' mock $ - sendAndConsumeCommitBundle commit - pure (events, reqs, qcnv) - - liftIO $ do - req <- assertOne $ filter ((== "on-conversation-updated") . frRPC) reqs - frTargetDomain req @?= qDomain bob - bdy <- case Aeson.eitherDecode (frBody req) of - Right b -> pure b - Left e -> assertFailure $ "Could not parse on-conversation-updated request body: " <> e - cuOrigUserId bdy @?= alice - cuConvId bdy @?= qUnqualified qcnv - cuAlreadyPresentUsers bdy @?= [qUnqualified bob] - cuAction bdy - @?= SomeConversationAction - SConversationJoinTag - ConversationJoin - { cjUsers = pure bob, - cjRole = roleNameWireMember - } - - liftIO $ do - event <- assertOne events - assertJoinEvent qcnv alice [bob] roleNameWireMember event - testCommitLock :: TestM () testCommitLock = do users <- createAndConnectUsers (replicate 4 Nothing) From dbbdf0300419ab5ab5faf901403e40dc5e119bb3 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 12:48:36 +0200 Subject: [PATCH 05/14] Add additional check to test --- services/galley/test/integration/API/MLS.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 2de4c1e34d..62b47400df 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -308,7 +308,7 @@ testAddUserWithBundle :: TestM () testAddUserWithBundle = do [alice, bob] <- createAndConnectUsers [Nothing, Nothing] - qcnv <- runMLSTest $ do + (qcnv, commit) <- runMLSTest $ do (alice1 : bobClients) <- traverse createMLSClient [alice, bob, bob] traverse_ uploadNewKeyPackage bobClients (_, qcnv) <- setupMLSGroup alice1 @@ -324,7 +324,7 @@ testAddUserWithBundle = do event <- assertOne events liftIO $ assertJoinEvent qcnv alice [bob] roleNameWireMember event - pure qcnv + pure (qcnv, commit) -- check that bob can now see the conversation convs <- @@ -335,6 +335,13 @@ testAddUserWithBundle = do "Users added to an MLS group should find it when listing conversations" (qcnv `elem` map cnvQualifiedId (convList convs)) + returnedGS <- + fmap responseBody $ + getGroupInfo (qUnqualified alice) qcnv + returnedGS + testAddUserWithBundleIncompleteWelcome :: TestM () testAddUserWithBundleIncompleteWelcome = do [alice, bob] <- createAndConnectUsers [Nothing, Nothing] From 3dc4f5aae3237bb4c62e9346624bdc1e6590053c Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 13:45:40 +0200 Subject: [PATCH 06/14] Add new test case: commit bundles to remote conv --- services/galley/test/integration/API/MLS.hs | 49 ++++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 62b47400df..1431c4d984 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -97,7 +97,6 @@ tests s = testGroup "Commit" [ test s "add user to a conversation" testAddUser, - test s "add user with a commit bundle" testAddUserWithBundle, test s "add user with an incomplete welcome" testAddUserWithBundleIncompleteWelcome, test s "add user (not connected)" testAddUserNotConnected, test s "add user (partial client list)" testAddUserPartial, @@ -173,6 +172,11 @@ tests s = [ test s "get group info for a local conversation" testGetGroupInfoOfLocalConv, test s "get group info for a remote conversation" testGetGroupInfoOfRemoteConv, test s "get group info for a remote user" testFederatedGetGroupInfo + ], + testGroup + "CommitBundle" + [ test s "add user with a commit bundle" testAddUserWithBundle, + test s "add user with a commit bundle to a remote conversation" testAddUserToRemoveConvWithBundle ] ] @@ -1914,3 +1918,46 @@ testDeleteMLSConv = do deleteTeamConv tid (qUnqualified qcnv) aliceUnq !!! statusCode === const 200 + +testAddUserToRemoveConvWithBundle :: TestM () +testAddUserToRemoveConvWithBundle = do + let aliceDomain = Domain "faraway.example.com" + [alice, bob, charlie] <- createAndConnectUsers [Just (domainText aliceDomain), Nothing, Nothing] + + runMLSTest $ do + [alice1, bob1] <- traverse createMLSClient [alice, bob] + + void $ uploadNewKeyPackage bob1 + (groupId, qcnv) <- setupFakeMLSGroup alice1 + + mp <- createAddCommit alice1 [bob] + traverse_ consumeWelcome (mpWelcome mp) + + receiveNewRemoteConv qcnv groupId + receiveOnConvUpdated qcnv alice bob + + -- NB. this commit would be rejected by the owning backend, but for the + -- purpose of this test it's good enough. + [charlie1] <- traverse createMLSClient [charlie] + void $ uploadNewKeyPackage charlie1 + commit <- createAddCommit bob1 [charlie] + commitBundle <- createBundle commit + + let mock req = case frRPC req of + "send-mls-commit-bundle" -> pure (Aeson.encode (MLSMessageResponseUpdates [])) + s -> error ("unmocked: " <> T.unpack s) + (_, reqs) <- withTempMockFederator' mock $ do + void $ sendAndConsumeCommitBundle commit + + req <- liftIO $ assertOne reqs + liftIO $ do + frRPC req @?= "send-mls-commit-bundle" + frTargetDomain req @?= qDomain qcnv + + msr <- case Aeson.eitherDecode (frBody req) of + Right b -> pure b + Left e -> assertFailure $ "Could not parse send-mls-commit-bundle request body: " <> e + + msrConvId msr @?= qUnqualified qcnv + msrSender msr @?= qUnqualified bob + fromBase64ByteString (msrRawMessage msr) @?= commitBundle From c25881281406a6d8b2edf77b55908225628ea111 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 13:54:50 +0200 Subject: [PATCH 07/14] Add test case: Commit bundle from remote user --- services/galley/test/integration/API/MLS.hs | 44 ++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 1431c4d984..8aa9bfb294 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -176,7 +176,8 @@ tests s = testGroup "CommitBundle" [ test s "add user with a commit bundle" testAddUserWithBundle, - test s "add user with a commit bundle to a remote conversation" testAddUserToRemoveConvWithBundle + test s "add user with a commit bundle to a remote conversation" testAddUserToRemoveConvWithBundle, + test s "remote user posts commit bundle" testRemoteUserPostsCommitBundle ] ] @@ -1961,3 +1962,44 @@ testAddUserToRemoveConvWithBundle = do msrConvId msr @?= qUnqualified qcnv msrSender msr @?= qUnqualified bob fromBase64ByteString (msrRawMessage msr) @?= commitBundle + +testRemoteUserPostsCommitBundle :: TestM () +testRemoteUserPostsCommitBundle = do + let bobDomain = "bob.example.com" + [alice, bob, charlie] <- createAndConnectUsers [Nothing, Just bobDomain, Just bobDomain] + fedGalleyClient <- view tsFedGalleyClient + + runMLSTest $ do + [alice1, bob1] <- traverse createMLSClient [alice, bob] + (_, qcnv) <- setupMLSGroup alice1 + + let mock req = case frRPC req of + "on-conversation-updated" -> pure (Aeson.encode ()) + "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) + "get-mls-clients" -> + pure + . Aeson.encode + . Set.fromList + . map (flip ClientInfo True . ciClient) + $ [bob1] + "mls-welcome" -> pure (Aeson.encode EmptyResponse) + ms -> assertFailure ("unmocked endpoint called: " <> cs ms) + + commit <- createAddCommit alice1 [bob] + void $ + withTempMockFederator' mock $ do + void $ sendAndConsumeCommit commit + putOtherMemberQualified (qUnqualified alice) bob (OtherMemberUpdate (Just roleNameWireAdmin)) qcnv + !!! const 200 === statusCode + + [_charlie1] <- traverse createMLSClient [charlie] + commitAddCharlie <- createAddCommit bob1 [charlie] + commitBundle <- createBundle commitAddCharlie + + let msr = MessageSendRequest (qUnqualified qcnv) (qUnqualified bob) (Base64ByteString commitBundle) + -- we can't fully test it, because remote admins are not implemeted, but + -- at least this proves that proposal processing has started on the + -- backend + MLSMessageResponseError MLSUnsupportedProposal <- runFedClient @"send-mls-commit-bundle" fedGalleyClient (Domain bobDomain) msr + + pure () From 1c20fd606ee9c77eff3de831a98f52459990a71c Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 19 Oct 2022 15:01:30 +0200 Subject: [PATCH 08/14] reformat wire-message-proto-lens.cabal --- .../wire-message-proto-lens.cabal | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal index 3f49049fac..4677d7bbf0 100644 --- a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal +++ b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal @@ -9,8 +9,9 @@ maintainer: Wire Swiss GmbH copyright: (c) 2021 Wire Swiss GmbH license: AGPL-3 build-type: Custom -extra-source-files: generic-message-proto/proto/otr.proto - , generic-message-proto/proto/mls.proto +extra-source-files: + generic-message-proto/proto/mls.proto + generic-message-proto/proto/otr.proto custom-setup setup-depends: @@ -20,10 +21,10 @@ custom-setup library exposed-modules: - Proto.Otr - Proto.Otr_Fields Proto.Mls Proto.Mls_Fields + Proto.Otr + Proto.Otr_Fields other-modules: Paths_wire_message_proto_lens hs-source-dirs: ./. From d460c64e73586a9ae14de5f263c8669738ef9392 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 20 Oct 2022 14:33:47 +0200 Subject: [PATCH 09/14] add changelog entry --- changelog.d/1-api-changes/pr-2773 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/1-api-changes/pr-2773 diff --git a/changelog.d/1-api-changes/pr-2773 b/changelog.d/1-api-changes/pr-2773 new file mode 100644 index 0000000000..e8add80051 --- /dev/null +++ b/changelog.d/1-api-changes/pr-2773 @@ -0,0 +1 @@ +Change mime type of body of /v3/mls/commit-bundles endpoint From 41a561a350b1fdc313718eb01b773c36b1957f39 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 24 Oct 2022 07:29:04 +0000 Subject: [PATCH 10/14] Renamed protoLabel --- libs/wire-api/src/Wire/API/ConverProtoLens.hs | 4 ++-- libs/wire-api/src/Wire/API/MLS/CommitBundle.hs | 8 ++++---- libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs | 8 ++++---- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/ConverProtoLens.hs b/libs/wire-api/src/Wire/API/ConverProtoLens.hs index 60a5e9568d..d19b8c08d8 100644 --- a/libs/wire-api/src/Wire/API/ConverProtoLens.hs +++ b/libs/wire-api/src/Wire/API/ConverProtoLens.hs @@ -27,5 +27,5 @@ class ConvertProtoLens a b where toProtolens :: b -> a -- | Add labels to error messages -label :: Text -> Either Text a -> Either Text a -label lbl = first ((lbl <> ": ") <>) +protoLabel :: Text -> Either Text a -> Either Text a +protoLabel lbl = first ((lbl <> ": ") <>) diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index bc5783dccf..28734b2e44 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -42,17 +42,17 @@ data CommitBundle = CommitBundle deriving (Eq, Show) instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where - fromProtolens protoBundle = CP.label "CommitBundle" $ do + fromProtolens protoBundle = CP.protoLabel "CommitBundle" $ do CommitBundle - <$> CP.label "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) - <*> CP.label + <$> CP.protoLabel "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) + <*> CP.protoLabel "welcome" ( let bs = view Proto.Mls.welcome protoBundle in if BS.length bs == 0 then pure Nothing else Just <$> decodeMLS' bs ) - <*> CP.label "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) + <*> CP.protoLabel "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) toProtolens bundle = let commitData = rmRaw (cbCommitMsg bundle) welcomeData = maybe mempty rmRaw (cbWelcome bundle) diff --git a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs index 78aac8487a..e8e4e1058c 100644 --- a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs @@ -64,11 +64,11 @@ data GroupInfoBundle = GroupInfoBundle instance ConvertProtoLens Proto.Mls.GroupInfoBundle GroupInfoBundle where fromProtolens protoBundle = - CP.label "GroupInfoBundle" $ + CP.protoLabel "GroupInfoBundle" $ GroupInfoBundle - <$> CP.label "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) - <*> CP.label "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) - <*> CP.label "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) + <$> CP.protoLabel "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) + <*> CP.protoLabel "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) + <*> CP.protoLabel "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) toProtolens bundle = let encryptionType = toProtolens (gipGroupInfoType bundle) treeType = toProtolens (gipRatchetTreeType bundle) From effe593f51f4c8a09e4dd7f777ad8409692ad157 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 24 Oct 2022 08:00:47 +0000 Subject: [PATCH 11/14] Linted and formatted --- .hlint.yaml | 1 + libs/wire-api/src/Wire/API/Call/Config.hs | 2 +- .../wire-api/src/Wire/API/MLS/CommitBundle.hs | 2 +- libs/wire-api/src/Wire/API/User/Profile.hs | 2 +- libs/zauth/src/Data/ZAuth/Token.hs | 2 +- services/brig/src/Brig/API/Client.hs | 4 +- services/brig/src/Brig/API/Public/Swagger.hs | 2 - .../brig/src/Brig/CanonicalInterpreter.hs | 40 ++++++++++--------- services/brig/src/Brig/Provider/API.hs | 2 +- services/brig/src/Brig/User/API/Handle.hs | 2 +- .../brig/test/integration/API/User/Client.hs | 13 +++--- services/galley/src/Galley/API/Update.hs | 2 +- services/galley/src/Galley/Intra/Spar.hs | 2 +- services/gundeck/test/unit/Native.hs | 4 +- .../spar/test-integration/Test/MetricsSpec.hs | 2 +- 15 files changed, 41 insertions(+), 41 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 95735a3ca8..3aac4d9b13 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -16,6 +16,7 @@ # custom rules: - hint: { lhs: (() <$), rhs: void } - hint: { lhs: return, rhs: pure } +- hint: { lhs: maybe mempty, rhs: foldMap } # We want the latter function because it handles signals properly. - error: { name: Use shutdown, lhs: runSettings, rhs: runSettingsWithShutdown } diff --git a/libs/wire-api/src/Wire/API/Call/Config.hs b/libs/wire-api/src/Wire/API/Call/Config.hs index 3777bdcbb7..4c45d67875 100644 --- a/libs/wire-api/src/Wire/API/Call/Config.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -255,7 +255,7 @@ instance BC.ToByteString TurnURI where <> BC.builder h <> byteString ":" <> BC.builder p - <> maybe mempty ((byteString "?transport=" <>) . BC.builder) tp + <> foldMap ((byteString "?transport=" <>) . BC.builder) tp instance BC.FromByteString TurnURI where parser = BC.parser >>= either fail pure . parseTurnURI diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index 28734b2e44..73d09f149f 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -55,7 +55,7 @@ instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where <*> CP.protoLabel "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) toProtolens bundle = let commitData = rmRaw (cbCommitMsg bundle) - welcomeData = maybe mempty rmRaw (cbWelcome bundle) + welcomeData = foldMap rmRaw (cbWelcome bundle) groupInfoData = toProtolens (cbGroupInfoBundle bundle) in ( Data.ProtoLens.defMessage & Proto.Mls.commit .~ commitData diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index 37b3557e31..f634fe7f08 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -185,7 +185,7 @@ instance Show Locale where show = Text.unpack . locToText locToText :: Locale -> Text -locToText (Locale l c) = lan2Text l <> maybe mempty (("-" <>) . con2Text) c +locToText (Locale l c) = lan2Text l <> foldMap (("-" <>) . con2Text) c parseLocale :: Text -> Maybe Locale parseLocale = hush . parseOnly localeParser diff --git a/libs/zauth/src/Data/ZAuth/Token.hs b/libs/zauth/src/Data/ZAuth/Token.hs index a4319822dc..50966b5310 100644 --- a/libs/zauth/src/Data/ZAuth/Token.hs +++ b/libs/zauth/src/Data/ZAuth/Token.hs @@ -339,7 +339,7 @@ writeHeader t = <> dot <> field "t" (t ^. typ) <> dot - <> field "l" (maybe mempty builder (t ^. tag)) + <> field "l" (foldMap builder (t ^. tag)) instance ToByteString Access where builder t = diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 9d0a5b8775..16aa14c0a7 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -349,8 +349,8 @@ claimLocalMultiPrekeyBundles protectee userClients = do e <- ask AppT $ lift $ - fmap (Map.fromListWith (<>)) $ - unsafePooledMapConcurrentlyN + Map.fromListWith (<>) + <$> unsafePooledMapConcurrentlyN 16 (\(u, cids) -> (u,) <$> lowerAppT e (getUserKeys u cids)) (Map.toList m) diff --git a/services/brig/src/Brig/API/Public/Swagger.hs b/services/brig/src/Brig/API/Public/Swagger.hs index ba103186d3..801e57f60c 100644 --- a/services/brig/src/Brig/API/Public/Swagger.hs +++ b/services/brig/src/Brig/API/Public/Swagger.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - module Brig.API.Public.Swagger ( SwaggerDocsAPI, pregenSwagger, diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index e57229eeef..d6076ce31a 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -57,23 +57,25 @@ type BrigCanonicalEffects = runBrigToIO :: Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = do - (either throwM pure =<<) - . runFinal - . unsafelyPerformConcurrency - . embedToFinal - . loggerToTinyLog (e ^. applog) - . runError @SomeException - . mapError @ParseException SomeException - . interpretClientToIO (e ^. casClient) - . interpretRpcToIO (e ^. httpManager) (e ^. requestId) - . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) - . interpretGalleyProviderToRPC - . codeStoreToCassandra @Cas.Client - . nowToIOAction (e ^. currentTime) - . userPendingActivationStoreToCassandra - . passwordResetStoreToCodeStore - . interpretBlacklistStoreToCassandra @Cas.Client - . interpretBlacklistPhonePrefixStoreToCassandra @Cas.Client - . interpretJwtTools - . interpretPublicKeyBundle + ( either throwM pure + <=< ( runFinal + . unsafelyPerformConcurrency + . embedToFinal + . loggerToTinyLog (e ^. applog) + . runError @SomeException + . mapError @ParseException SomeException + . interpretClientToIO (e ^. casClient) + . interpretRpcToIO (e ^. httpManager) (e ^. requestId) + . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) + . interpretGalleyProviderToRPC + . codeStoreToCassandra @Cas.Client + . nowToIOAction (e ^. currentTime) + . userPendingActivationStoreToCassandra + . passwordResetStoreToCodeStore + . interpretBlacklistStoreToCassandra @Cas.Client + . interpretBlacklistPhonePrefixStoreToCassandra @Cas.Client + . interpretJwtTools + . interpretPublicKeyBundle + ) + ) $ runReaderT ma e diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index f8c1c4ad0f..336bd8ba38 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -723,7 +723,7 @@ deleteAccountH :: ExceptT Error (AppT r) Response deleteAccountH (pid ::: req) = do guardSecondFactorDisabled Nothing - empty <$ (mapExceptT wrapHttpClient $ deleteAccount pid =<< parseJsonBody req) + empty <$ mapExceptT wrapHttpClient (deleteAccount pid =<< parseJsonBody req) deleteAccount :: ( MonadReader Env m, diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index c32303e49c..fb3d49c4f1 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -76,7 +76,7 @@ getLocalHandleInfo self handle = do Nothing -> pure Nothing Just ownerId -> do domain <- viewFederationDomain - ownerProfile <- (API.lookupProfile self (Qualified ownerId domain)) !>> fedError + ownerProfile <- API.lookupProfile self (Qualified ownerId domain) !>> fedError owner <- filterHandleResults self (maybeToList ownerProfile) pure $ listToMaybe owner diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 1123a89481..4bb79fad04 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -441,13 +441,12 @@ testClientsWithoutPrekeys brig cannon db opts = do const 200 === statusCode const ( Right $ - ( expectedClientMap - domain - uid1 - [ (clientId c11, Nothing), - (clientId c12, Just pk12) - ] - ) + expectedClientMap + domain + uid1 + [ (clientId c11, Nothing), + (clientId c12, Just pk12) + ] ) === responseJsonEither diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 27b2d6c806..b085feabb3 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -1269,7 +1269,7 @@ unqualifyEndpoint loc f ignoreMissing reportMissing message = do qualifiedNewOtrNativePush = newOtrNativePush message, qualifiedNewOtrTransient = newOtrTransient message, qualifiedNewOtrNativePriority = newOtrNativePriority message, - qualifiedNewOtrData = maybe mempty fromBase64TextLenient (newOtrData message), + qualifiedNewOtrData = foldMap fromBase64TextLenient (newOtrData message), qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy } unqualify (tDomain loc) <$> f qualifiedMessage diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index e9429ca244..7d005d8585 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -47,4 +47,4 @@ lookupScimUserInfos uids = do method POST . paths ["i", "scim", "userinfos"] . json (UserSet $ Set.fromList uids) - pure $ maybe mempty scimUserInfos $ responseJsonMaybe response + pure $ foldMap scimUserInfos $ responseJsonMaybe response diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs index 27fee4380d..0d99b69600 100644 --- a/services/gundeck/test/unit/Native.hs +++ b/services/gundeck/test/unit/Native.hs @@ -79,10 +79,10 @@ instance FromJSON SnsNotification where where parseApns t n = let apn = decodeStrict' (T.encodeUtf8 n) - in maybe mempty (pure . SnsNotification t . SnsApnsData) apn + in foldMap (pure . SnsNotification t . SnsApnsData) apn parseGcm n = let gcm = decodeStrict' (T.encodeUtf8 n) - in maybe mempty (pure . SnsNotification GCM . SnsGcmData) gcm + in foldMap (pure . SnsNotification GCM . SnsGcmData) gcm data SnsData = SnsGcmData !GcmData diff --git a/services/spar/test-integration/Test/MetricsSpec.hs b/services/spar/test-integration/Test/MetricsSpec.hs index ab6a87136b..32f2d845d1 100644 --- a/services/spar/test-integration/Test/MetricsSpec.hs +++ b/services/spar/test-integration/Test/MetricsSpec.hs @@ -37,7 +37,7 @@ spec = describe "metrics" . it "works" $ do _ <- call $ get (spar . path p1) _ <- call $ get (spar . path (p2 "316f1c18-2980-11e9-ab0b-ef604d1791b2")) _ <- call $ get (spar . path (p2 "60a7dda8-2980-11e9-b359-fb5b41565453")) - resp :: String <- call $ maybe mempty cs . responseBody <$> get (spar . path "i/metrics") + resp :: String <- call $ foldMap cs . responseBody <$> get (spar . path "i/metrics") -- FUTUREWORK: here we could parse the prometheus 'RegistrySample' and inspect it more -- thoroughly, but i'm not sure there is a parser. liftIO $ do From 22f679e84571d6ccb08d4c98cd1ab0ed636f8e45 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 24 Oct 2022 08:29:50 +0000 Subject: [PATCH 12/14] Added fundeps to convert proto lens. --- libs/wire-api/src/Wire/API/ConverProtoLens.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/ConverProtoLens.hs b/libs/wire-api/src/Wire/API/ConverProtoLens.hs index d19b8c08d8..6e4398c47f 100644 --- a/libs/wire-api/src/Wire/API/ConverProtoLens.hs +++ b/libs/wire-api/src/Wire/API/ConverProtoLens.hs @@ -22,7 +22,9 @@ import Imports -- | This typeclass exists to provide overloaded function names for convertion -- between data types generated by proto-lens and data types used in wire -class ConvertProtoLens a b where +-- We added fundeps here for better type inference, but we can't be as explicit as we wanted +-- with @a -> b, b -> a@, since our instances would be orphaned on the left hand side argument. +class ConvertProtoLens a b | b -> a where fromProtolens :: a -> Either Text b toProtolens :: b -> a From dbd24889b6787919f1ee26170523acb7245d0048 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 24 Oct 2022 08:50:35 +0000 Subject: [PATCH 13/14] Updated mimetype --- libs/wire-api/src/Wire/API/MLS/Servant.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/MLS/Servant.hs b/libs/wire-api/src/Wire/API/MLS/Servant.hs index b735e8e1a8..33831f241b 100644 --- a/libs/wire-api/src/Wire/API/MLS/Servant.hs +++ b/libs/wire-api/src/Wire/API/MLS/Servant.hs @@ -45,7 +45,7 @@ mimeUnrenderMLSWith p = first T.unpack . decodeMLSWith p data CommitBundleMimeType instance Accept CommitBundleMimeType where - contentType _ = "application" // "vnd.wire.commit-bundle" + contentType _ = "application" // "x-protobuf" instance MimeUnrender CommitBundleMimeType CommitBundle where mimeUnrender _ = first T.unpack . deserializeCommitBundle . LBS.toStrict From 1002a8401daa022941d1934aeaf7a304991ab083 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 24 Oct 2022 09:28:35 +0000 Subject: [PATCH 14/14] Removed redundant qualified --- libs/wire-api/src/Wire/API/MLS/CommitBundle.hs | 9 ++++----- libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs | 9 ++++----- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs index 73d09f149f..e04902d969 100644 --- a/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/CommitBundle.hs @@ -28,7 +28,6 @@ import Imports import qualified Proto.Mls import qualified Proto.Mls_Fields as Proto.Mls import Wire.API.ConverProtoLens -import qualified Wire.API.ConverProtoLens as CP import Wire.API.MLS.GroupInfoBundle import Wire.API.MLS.Message import Wire.API.MLS.Serialisation @@ -42,17 +41,17 @@ data CommitBundle = CommitBundle deriving (Eq, Show) instance ConvertProtoLens Proto.Mls.CommitBundle CommitBundle where - fromProtolens protoBundle = CP.protoLabel "CommitBundle" $ do + fromProtolens protoBundle = protoLabel "CommitBundle" $ do CommitBundle - <$> CP.protoLabel "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) - <*> CP.protoLabel + <$> protoLabel "commit" (decodeMLS' (view Proto.Mls.commit protoBundle)) + <*> protoLabel "welcome" ( let bs = view Proto.Mls.welcome protoBundle in if BS.length bs == 0 then pure Nothing else Just <$> decodeMLS' bs ) - <*> CP.protoLabel "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) + <*> protoLabel "group_info_bundle" (fromProtolens (view Proto.Mls.groupInfoBundle protoBundle)) toProtolens bundle = let commitData = rmRaw (cbCommitMsg bundle) welcomeData = foldMap rmRaw (cbWelcome bundle) diff --git a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs index e8e4e1058c..93cc706e98 100644 --- a/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs +++ b/libs/wire-api/src/Wire/API/MLS/GroupInfoBundle.hs @@ -24,7 +24,6 @@ import qualified Proto.Mls import qualified Proto.Mls_Fields as Proto.Mls import Test.QuickCheck import Wire.API.ConverProtoLens -import qualified Wire.API.ConverProtoLens as CP import Wire.API.MLS.PublicGroupState import Wire.API.MLS.Serialisation import Wire.Arbitrary @@ -64,11 +63,11 @@ data GroupInfoBundle = GroupInfoBundle instance ConvertProtoLens Proto.Mls.GroupInfoBundle GroupInfoBundle where fromProtolens protoBundle = - CP.protoLabel "GroupInfoBundle" $ + protoLabel "GroupInfoBundle" $ GroupInfoBundle - <$> CP.protoLabel "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) - <*> CP.protoLabel "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) - <*> CP.protoLabel "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) + <$> protoLabel "field group_info_type" (fromProtolens (view Proto.Mls.groupInfoType protoBundle)) + <*> protoLabel "field ratchet_tree_type" (fromProtolens (view Proto.Mls.ratchetTreeType protoBundle)) + <*> protoLabel "field group_info" (decodeMLS' (view Proto.Mls.groupInfo protoBundle)) toProtolens bundle = let encryptionType = toProtolens (gipGroupInfoType bundle) treeType = toProtolens (gipRatchetTreeType bundle)