diff --git a/changelog.d/5-internal/mls-integration b/changelog.d/5-internal/mls-integration new file mode 100644 index 0000000000..721c32f4e1 --- /dev/null +++ b/changelog.d/5-internal/mls-integration @@ -0,0 +1 @@ +Port MLS test framework to new integration suite diff --git a/integration/default.nix b/integration/default.nix index 6ada6449f7..ceec8be2ed 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -8,6 +8,7 @@ , array , async , base +, base64-bytestring , bytestring , bytestring-conversion , Cabal @@ -18,8 +19,10 @@ , exceptions , filepath , gitignoreSource +, hex , http-client , http-types +, kan-extensions , lib , mtl , network @@ -34,10 +37,13 @@ , stm , string-conversions , tagged +, temporary , text , time , transformers +, unix , unliftio +, uuid , websockets , yaml }: @@ -54,6 +60,7 @@ mkDerivation { array async base + base64-bytestring bytestring bytestring-conversion case-insensitive @@ -62,8 +69,10 @@ mkDerivation { directory exceptions filepath + hex http-client http-types + kan-extensions mtl network network-uri @@ -77,10 +86,13 @@ mkDerivation { stm string-conversions tagged + temporary text time transformers + unix unliftio + uuid websockets yaml ]; diff --git a/integration/integration.cabal b/integration/integration.cabal index f6bb83cd21..357ca62715 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -84,6 +84,7 @@ library API.Common API.Galley API.GalleyInternal + MLS.Util RunAllTests SetupHelpers Test.B2B @@ -109,6 +110,7 @@ library , array , async , base + , base64-bytestring , bytestring , bytestring-conversion , case-insensitive @@ -117,8 +119,10 @@ library , directory , exceptions , filepath + , hex , http-client , http-types + , kan-extensions , mtl , network , network-uri @@ -132,9 +136,12 @@ library , stm , string-conversions , tagged + , temporary , text , time , transformers + , unix , unliftio + , uuid , websockets , yaml diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 2163a22060..20d42ca701 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -1,8 +1,11 @@ module API.Brig where import API.Common +import qualified Data.ByteString.Base64 as Base64 +import Data.Foldable import Data.Function import Data.Maybe +import qualified Data.Text.Encoding as T import GHC.Stack import Testlib.Prelude @@ -49,6 +52,43 @@ addClient user args = do "password" .= args.password ] +data UpdateClient = UpdateClient + { prekeys :: [Value], + lastPrekey :: Maybe Value, + label :: Maybe String, + capabilities :: Maybe [Value], + mlsPublicKeys :: Maybe Value + } + +instance Default UpdateClient where + def = + UpdateClient + { prekeys = [], + lastPrekey = Nothing, + label = Nothing, + capabilities = Nothing, + mlsPublicKeys = Nothing + } + +updateClient :: + HasCallStack => + ClientIdentity -> + UpdateClient -> + App Response +updateClient cid args = do + uid <- objId cid + req <- baseRequest cid Brig Versioned $ "/clients/" <> cid.client + submit "PUT" $ + req + & zUser uid + & addJSONObject + ( ["prekeys" .= args.prekeys] + <> ["lastkey" .= k | k <- toList args.lastPrekey] + <> ["label" .= l | l <- toList args.label] + <> ["capabilities" .= c | c <- toList args.capabilities] + <> ["mls_public_keys" .= k | k <- toList args.mlsPublicKeys] + ) + deleteClient :: (HasCallStack, MakesValue user, MakesValue client) => user -> @@ -137,3 +177,25 @@ putConnection userFrom userTo status = do & contentTypeJSON & addJSONObject ["status" .= statusS] ) + +uploadKeyPackage :: ClientIdentity -> ByteString -> App Response +uploadKeyPackage cid kp = do + req <- + baseRequest cid Brig Versioned $ + "/mls/key-packages/self/" <> cid.client + uid <- objId cid + submit + "POST" + ( req + & zUser uid + & addJSONObject ["key_packages" .= [T.decodeUtf8 (Base64.encode kp)]] + ) + +claimKeyPackages :: (MakesValue u, MakesValue v) => u -> v -> App Response +claimKeyPackages u v = do + (targetDom, targetUid) <- objQid v + req <- + baseRequest u Brig Versioned $ + "/mls/key-packages/claim/" <> targetDom <> "/" <> targetUid + uid <- objId u + submit "POST" (req & zUser uid) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 431410936a..15204f5536 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -116,3 +116,87 @@ getConversation user qcnv = do ( req & zUser uid ) + +getSubConversation :: + ( HasCallStack, + MakesValue user, + MakesValue conv + ) => + user -> + conv -> + String -> + App Response +getSubConversation user conv sub = do + uid <- objId user + (cnvDomain, cnvId) <- objQid conv + req <- + baseRequest user Galley Versioned $ + joinHttpPath + [ "conversations", + cnvDomain, + cnvId, + "subconversations", + sub + ] + submit "GET" $ req & zUser uid + +getSelfConversation :: (HasCallStack, MakesValue user) => user -> App Response +getSelfConversation user = do + uid <- objId user + req <- baseRequest user Galley Versioned "/conversations/mls-self" + submit "GET" $ req & zUser uid & zConnection "conn" + +data ListConversationIds = ListConversationIds {pagingState :: Maybe String, size :: Maybe Int} + +instance Default ListConversationIds where + def = ListConversationIds Nothing Nothing + +listConversationIds :: MakesValue user => user -> ListConversationIds -> App Response +listConversationIds user args = do + req <- baseRequest user Galley Versioned "/conversations/list-ids" + uid <- objId user + submit "POST" $ + req + & zUser uid + & addJSONObject + ( ["paging_state" .= s | s <- toList args.pagingState] + <> ["size" .= s | s <- toList args.size] + ) + +listConversations :: MakesValue user => user -> [Value] -> App Response +listConversations user cnvs = do + req <- baseRequest user Galley Versioned "/conversations/list" + uid <- objId user + submit "POST" $ + req + & zUser uid + & addJSONObject ["qualified_ids" .= cnvs] + +postMLSMessage :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSMessage cid msg = do + req <- baseRequest cid Galley Versioned "/mls/messages" + uid <- objId cid + c <- cid %. "client" & asString + submit "POST" (addMLS msg req & zUser uid & zClient c & zConnection "conn") + +postMLSCommitBundle :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSCommitBundle cid msg = do + req <- baseRequest cid Galley Versioned "/mls/commit-bundles" + uid <- objId cid + c <- cid %. "client_id" & asString + submit "POST" (addMLS msg req & zUser uid & zClient c & zConnection "conn") + +getGroupInfo :: + (HasCallStack, MakesValue user, MakesValue conv) => + user -> + conv -> + App Response +getGroupInfo user conv = do + (qcnv, mSub) <- objSubConv conv + (convDomain, convId) <- objQid qcnv + let path = joinHttpPath $ case mSub of + Nothing -> ["conversations", convDomain, convId, "groupinfo"] + Just sub -> ["conversations", convDomain, convId, "subconversations", sub, "groupinfo"] + req <- baseRequest user Galley Versioned path + uid <- objId user + submit "GET" (req & zUser uid & zConnection "conn") diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs new file mode 100644 index 0000000000..0275e823ac --- /dev/null +++ b/integration/test/MLS/Util.hs @@ -0,0 +1,523 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module MLS.Util where + +import API.Brig +import API.Galley +import Control.Concurrent.Async hiding (link) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Cont +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Aeson (Value (..), object) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as B8 +import Data.Default +import Data.Foldable +import Data.Function +import Data.Hex +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text.Encoding as T +import Data.Traversable +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUIDV4 +import GHC.Stack +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.IO.Temp +import System.Posix.Files +import System.Process +import Testlib.App +import Testlib.Assertions +import Testlib.Env +import Testlib.HTTP +import Testlib.JSON +import Testlib.Types + +mkClientIdentity :: (MakesValue u, MakesValue c) => u -> c -> App ClientIdentity +mkClientIdentity u c = do + (domain, user) <- objQid u + client <- c %. "id" & asString + pure $ ClientIdentity {domain = domain, user = user, client = client} + +cid2Str :: ClientIdentity -> String +cid2Str cid = cid.user <> ":" <> cid.client <> "@" <> cid.domain + +data MessagePackage = MessagePackage + { sender :: ClientIdentity, + message :: ByteString, + welcome :: Maybe ByteString, + groupInfo :: Maybe ByteString + } + +getConv :: App Value +getConv = do + mls <- getMLSState + case mls.convId of + Nothing -> assertFailure "Uninitialised test conversation" + Just convId -> pure convId + +toRandomFile :: ByteString -> App FilePath +toRandomFile bs = do + p <- randomFileName + liftIO $ BS.writeFile p bs + pure p + +randomFileName :: App FilePath +randomFileName = do + bd <- getBaseDir + (bd ) . UUID.toString <$> liftIO UUIDV4.nextRandom + +mlscli :: HasCallStack => ClientIdentity -> [String] -> Maybe ByteString -> App ByteString +mlscli cid args mbstdin = do + bd <- getBaseDir + let cdir = bd cid2Str cid + + groupOut <- randomFileName + let substOut = argSubst "" groupOut + + hasState <- hasClientGroupState cid + substIn <- + if hasState + then do + gs <- getClientGroupState cid + fn <- toRandomFile gs + pure (argSubst "" fn) + else pure id + + out <- + spawn + ( proc + "mls-test-cli" + ( ["--store", cdir "store"] + <> map (substIn . substOut) args + ) + ) + mbstdin + + groupOutWritten <- liftIO $ doesFileExist groupOut + when groupOutWritten $ do + gs <- liftIO (BS.readFile groupOut) + setClientGroupState cid gs + pure out + +argSubst :: String -> String -> String -> String +argSubst from to_ s = + if s == from then to_ else s + +createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity +createWireClient u = do + lpk <- getLastPrekey + c <- addClient u def {lastPrekey = Just lpk} + mkClientIdentity u c + +initMLSClient :: HasCallStack => ClientIdentity -> App () +initMLSClient cid = do + bd <- getBaseDir + liftIO $ createDirectory (bd cid2Str cid) + void $ mlscli cid ["init", cid2Str cid] Nothing + +-- | Create new mls client and register with backend. +createMLSClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity +createMLSClient u = do + cid <- createWireClient u + initMLSClient cid + + -- set public key + pkey <- mlscli cid ["public-key"] Nothing + bindResponse + ( updateClient + cid + def + { mlsPublicKeys = + Just (object ["ed25519" .= T.decodeUtf8 (Base64.encode pkey)]) + } + ) + $ \resp -> resp.status `shouldMatchInt` 200 + pure cid + +-- | create and upload to backend +uploadNewKeyPackage :: HasCallStack => ClientIdentity -> App String +uploadNewKeyPackage cid = do + (kp, ref) <- generateKeyPackage cid + + -- upload key package + bindResponse (uploadKeyPackage cid kp) $ \resp -> + resp.status `shouldMatchInt` 201 + + pure ref + +generateKeyPackage :: HasCallStack => ClientIdentity -> App (ByteString, String) +generateKeyPackage cid = do + kp <- mlscli cid ["key-package", "create"] Nothing + ref <- B8.unpack . hex <$> mlscli cid ["key-package", "ref", "-"] (Just kp) + fp <- keyPackageFile cid ref + liftIO $ BS.writeFile fp kp + pure (kp, ref) + +-- | Create conversation and corresponding group. +setupMLSGroup :: HasCallStack => ClientIdentity -> App (String, Value) +setupMLSGroup cid = do + conv <- bindResponse (postConversation cid (Just cid.client) defMLS) $ \resp -> do + resp.status `shouldMatchInt` 201 + pure resp.json + groupId <- conv %. "group_id" & asString + convId <- conv %. "qualified_id" + createGroup cid conv + pure (groupId, convId) + +-- | Retrieve self conversation and create the corresponding group. +setupMLSSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value) +setupMLSSelfGroup cid = do + conv <- bindResponse (getSelfConversation cid) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "epoch" `shouldMatchInt` 0 + resp.json + groupId <- conv %. "group_id" & asString + convId <- conv %. "qualified_id" + createGroup cid conv + pure (groupId, convId) + +createGroup :: MakesValue conv => ClientIdentity -> conv -> App () +createGroup cid conv = do + mls <- getMLSState + case mls.groupId of + Just _ -> assertFailure "only one group can be created" + Nothing -> pure () + resetGroup cid conv + +resetGroup :: MakesValue conv => ClientIdentity -> conv -> App () +resetGroup cid conv = do + convId <- make conv + groupId <- conv %. "group_id" & asString + modifyMLSState $ \s -> + s + { groupId = Just groupId, + convId = Just convId, + members = Set.singleton cid, + epoch = 0, + newMembers = mempty + } + resetClientGroup cid groupId + +resetClientGroup :: ClientIdentity -> String -> App () +resetClientGroup cid gid = do + removalKeyPath <- asks (.removalKeyPath) + groupJSON <- + mlscli + cid + [ "group", + "create", + "--removal-key", + removalKeyPath, + gid + ] + Nothing + setClientGroupState cid groupJSON + +keyPackageFile :: HasCallStack => ClientIdentity -> String -> App FilePath +keyPackageFile cid ref = do + bd <- getBaseDir + pure $ bd cid2Str cid ref + +unbundleKeyPackages :: Value -> App [(ClientIdentity, ByteString)] +unbundleKeyPackages bundle = do + let entryIdentity be = do + d <- be %. "domain" & asString + u <- be %. "user" & asString + c <- be %. "client" & asString + pure $ ClientIdentity {domain = d, user = u, client = c} + + bundleEntries <- bundle %. "key_packages" & asList + for bundleEntries $ \be -> do + kp64 <- be %. "key_package" & asString + kp <- assertOne . toList . Base64.decode . B8.pack $ kp64 + cid <- entryIdentity be + pure (cid, kp) + +-- | Claim keypackages and create a commit/welcome pair on a given client. +-- Note that this alters the state of the group immediately. If we want to test +-- a scenario where the commit is rejected by the backend, we can restore the +-- group to the previous state by using an older version of the group file. +createAddCommit :: HasCallStack => ClientIdentity -> [Value] -> App MessagePackage +createAddCommit cid users = do + kps <- fmap concat . for users $ \user -> do + bundle <- bindResponse (claimKeyPackages cid user) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + unbundleKeyPackages bundle + createAddCommitWithKeyPackages cid kps + +withTempKeyPackageFile :: ByteString -> ContT a App FilePath +withTempKeyPackageFile bs = do + bd <- lift getBaseDir + ContT $ \k -> + bracket + (liftIO (openBinaryTempFile bd "kp")) + (\(fp, _) -> liftIO (removeFile fp)) + $ \(fp, h) -> do + liftIO $ BS.hPut h bs `finally` hClose h + k fp + +createAddCommitWithKeyPackages :: + ClientIdentity -> + [(ClientIdentity, ByteString)] -> + App MessagePackage +createAddCommitWithKeyPackages cid clientsAndKeyPackages = do + bd <- getBaseDir + welcomeFile <- liftIO $ emptyTempFile bd "welcome" + giFile <- liftIO $ emptyTempFile bd "gi" + + commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \kpFiles -> + mlscli + cid + ( [ "member", + "add", + "--group", + "", + "--welcome-out", + welcomeFile, + "--group-info-out", + giFile, + "--group-out", + "" + ] + <> kpFiles + ) + Nothing + + modifyMLSState $ \mls -> + mls + { newMembers = Set.fromList (map fst clientsAndKeyPackages) + } + + welcome <- liftIO $ BS.readFile welcomeFile + gi <- liftIO $ BS.readFile giFile + pure $ + MessagePackage + { sender = cid, + message = commit, + welcome = Just welcome, + groupInfo = Just gi + } + +createAddProposals :: HasCallStack => ClientIdentity -> [Value] -> App [MessagePackage] +createAddProposals cid users = do + bundles <- for users $ \u -> bindResponse (claimKeyPackages cid u) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + kps <- concat <$> traverse unbundleKeyPackages bundles + traverse (createAddProposalWithKeyPackage cid) kps + +createAddProposalWithKeyPackage :: + ClientIdentity -> + (ClientIdentity, ByteString) -> + App MessagePackage +createAddProposalWithKeyPackage cid (_, kp) = do + prop <- runContT (withTempKeyPackageFile kp) $ \kpFile -> + mlscli + cid + ["proposal", "--group-in", "", "--group-out", "", "add", kpFile] + Nothing + pure + MessagePackage + { sender = cid, + message = prop, + welcome = Nothing, + groupInfo = Nothing + } + +createPendingProposalCommit :: HasCallStack => ClientIdentity -> App MessagePackage +createPendingProposalCommit cid = do + bd <- getBaseDir + welcomeFile <- liftIO $ emptyTempFile bd "welcome" + pgsFile <- liftIO $ emptyTempFile bd "pgs" + commit <- + mlscli + cid + [ "commit", + "--group", + "", + "--group-out", + "", + "--welcome-out", + welcomeFile, + "--group-info-out", + pgsFile + ] + Nothing + + welcome <- liftIO $ readWelcome welcomeFile + pgs <- liftIO $ BS.readFile pgsFile + pure + MessagePackage + { sender = cid, + message = commit, + welcome = welcome, + groupInfo = Just pgs + } + +createExternalCommit :: + HasCallStack => + ClientIdentity -> + Maybe ByteString -> + App MessagePackage +createExternalCommit cid mgi = do + bd <- getBaseDir + giFile <- liftIO $ emptyTempFile bd "gi" + conv <- getConv + gi <- case mgi of + Nothing -> bindResponse (getGroupInfo cid conv) $ \resp -> do + resp.status `shouldMatchInt` 200 + pure resp.body + Just v -> pure v + commit <- + mlscli + cid + [ "external-commit", + "--group-info-in", + "-", + "--group-info-out", + giFile, + "--group-out", + "" + ] + (Just gi) + + modifyMLSState $ \mls -> + mls + { newMembers = Set.singleton cid + -- This might be a different client than those that have been in the + -- group from before. + } + + newPgs <- liftIO $ BS.readFile giFile + pure $ + MessagePackage + { sender = cid, + message = commit, + welcome = Nothing, + groupInfo = Just newPgs + } + +-- | Make all member clients consume a given message. +consumeMessage :: HasCallStack => MessagePackage -> App () +consumeMessage msg = do + mls <- getMLSState + for_ (Set.delete msg.sender mls.members) $ \cid -> + consumeMessage1 cid msg.message + +consumeMessage1 :: HasCallStack => ClientIdentity -> ByteString -> App () +consumeMessage1 cid msg = + void $ + mlscli + cid + [ "consume", + "--group", + "", + "--group-out", + "", + "-" + ] + (Just msg) + +-- | Send an MLS message and simulate clients receiving it. If the message is a +-- commit, the 'sendAndConsumeCommit' function should be used instead. +sendAndConsumeMessage :: HasCallStack => MessagePackage -> App Value +sendAndConsumeMessage mp = do + r <- bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do + resp.status `shouldMatchInt` 201 + resp.json + consumeMessage mp + pure r + +-- | Send an MLS commit bundle, simulate clients receiving it, and update the +-- test state accordingly. +sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value +sendAndConsumeCommitBundle mp = do + resp <- bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do + resp.status `shouldMatchInt` 201 + resp.json + consumeMessage mp + traverse_ consumeWelcome mp.welcome + + -- increment epoch and add new clients + modifyMLSState $ \mls -> + mls + { epoch = epoch mls + 1, + members = members mls <> newMembers mls, + newMembers = mempty + } + + pure resp + +consumeWelcome :: HasCallStack => ByteString -> App () +consumeWelcome welcome = do + mls <- getMLSState + for_ mls.newMembers $ \cid -> do + hasState <- hasClientGroupState cid + assertBool "Existing clients in a conversation should not consume welcomes" (not hasState) + void $ + mlscli + cid + [ "group", + "from-welcome", + "--group-out", + "", + "-" + ] + (Just welcome) + +readWelcome :: FilePath -> IO (Maybe ByteString) +readWelcome fp = runMaybeT $ do + liftIO (doesFileExist fp) >>= guard + stat <- liftIO $ getFileStatus fp + guard $ fileSize stat > 0 + liftIO $ BS.readFile fp + +mkBundle :: MessagePackage -> ByteString +mkBundle mp = mp.message <> foldMap mkGroupInfoMessage mp.groupInfo <> fold mp.welcome + +mkGroupInfoMessage :: ByteString -> ByteString +mkGroupInfoMessage gi = BS.pack [0x00, 0x01, 0x00, 0x04] <> gi + +spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString +spawn cp minput = do + (mout, ex) <- liftIO + $ withCreateProcess + cp + { std_out = CreatePipe, + std_in = if isJust minput then CreatePipe else Inherit + } + $ \minh mouth _ ph -> + let writeInput = for_ ((,) <$> minput <*> minh) $ \(input, inh) -> + BS.hPutStr inh input >> hClose inh + readOutput = (,) <$> traverse BS.hGetContents mouth <*> waitForProcess ph + in snd <$> concurrently writeInput readOutput + case (mout, ex) of + (Just out, ExitSuccess) -> pure out + _ -> assertFailure "Failed spawning process" + +hasClientGroupState :: HasCallStack => ClientIdentity -> App Bool +hasClientGroupState cid = do + mls <- getMLSState + pure $ Map.member cid mls.clientGroupState + +getClientGroupState :: HasCallStack => ClientIdentity -> App ByteString +getClientGroupState cid = do + mls <- getMLSState + case Map.lookup cid mls.clientGroupState of + Nothing -> assertFailure ("Attempted to get non-existing group state for client " <> cid2Str cid) + Just g -> pure g + +setClientGroupState :: HasCallStack => ClientIdentity -> ByteString -> App () +setClientGroupState cid g = + modifyMLSState $ \s -> + s {clientGroupState = Map.insert cid g (clientGroupState s)} diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index bec59fb6ad..a46e8e8cc5 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -2,6 +2,7 @@ module SetupHelpers where import qualified API.Brig as Public import qualified API.BrigInternal as Internal +import API.Galley import Data.Aeson import Data.Default import Data.Function @@ -46,3 +47,14 @@ createAndConnectUsers domains = do pure (a, b) for_ userPairs (uncurry connectUsers) pure users + +getAllConvs :: (HasCallStack, MakesValue u) => u -> App [Value] +getAllConvs u = do + page <- bindResponse (listConversationIds u def) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + ids <- page %. "qualified_conversations" & asList + result <- bindResponse (listConversations u ids) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + result %. "found" & asList diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index d8457855f4..aabf58aa61 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -46,7 +46,7 @@ a `shouldMatch` b = do unless (xa == xb) $ do pa <- prettyJSON xa pb <- prettyJSON xb - assertFailure $ "Expected:\n" <> pb <> "\n" <> "Actual:\n" <> pa + assertFailure $ "Actual:\n" <> pa <> "\nExpected:\n" <> pb shouldNotMatch :: (MakesValue a, MakesValue b, HasCallStack) => @@ -62,7 +62,12 @@ a `shouldNotMatch` b = do unless (jsonType xa == jsonType xb) $ do pa <- prettyJSON xa pb <- prettyJSON xb - assertFailure $ "Compared values are not of the same type:\n" <> "Left side:\n" <> pa <> "Right side:\n" <> pb + assertFailure $ + "Compared values are not of the same type:\n" + <> "Left side:\n" + <> pa + <> "\nRight side:\n" + <> pb when (xa == xb) $ do pa <- prettyJSON xa @@ -103,6 +108,13 @@ printFailureDetails (AssertionFailure stack mbResponse msg) = do : "\n" <> s : toList (fmap prettyResponse mbResponse) +printExceptionDetails :: SomeException -> IO String +printExceptionDetails e = do + pure . unlines $ + [ colored yellow "exception:", + colored red (displayException e) + ] + prettierCallStack :: CallStack -> IO String prettierCallStack cstack = do sl <- diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index 94df997820..e9ee3221a7 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -82,10 +82,12 @@ class ToWSConnect a where instance {-# OVERLAPPING #-} ToWSConnect WSConnect where toWSConnect = pure -instance {-# OVERLAPPABLE #-} (MakesValue user) => ToWSConnect user where +instance {-# OVERLAPPABLE #-} MakesValue user => ToWSConnect user where toWSConnect u = do uid <- objId u & asString - pure (WSConnect uid Nothing Nothing) + mc <- lookupField u "client_id" + c <- traverse asString mc + pure (WSConnect uid c Nothing) instance (MakesValue user, MakesValue conn) => ToWSConnect (user, conn) where toWSConnect (u, c) = do @@ -138,7 +140,7 @@ run wsConnect app = do let path = "/await" - <> ( case client wsConnect of + <> ( case wsConnect.client of Nothing -> "" Just client -> fromJust . fromByteString $ Http.queryString (Http.setQueryString [("client", Just (toByteString' client))] Http.defaultRequest) ) @@ -183,7 +185,7 @@ withWebSocket w k = do wsConnect <- toWSConnect w Catch.bracket (connect wsConnect) close k -withWebSockets :: forall a w. (HasCallStack, (ToWSConnect w)) => [w] -> ([WebSocket] -> App a) -> App a +withWebSockets :: forall a w. (HasCallStack, ToWSConnect w) => [w] -> ([WebSocket] -> App a) -> App a withWebSockets twcs k = do wcs <- for twcs toWSConnect go wcs [] diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index cfd77a79e7..69c859030e 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -1,12 +1,16 @@ module Testlib.Env where +import Control.Monad.Codensity +import Control.Monad.IO.Class import Data.Aeson hiding ((.=)) import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) import Data.Char import Data.Functor import Data.IORef import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import Data.String import Data.Word import qualified Data.Yaml as Yaml @@ -15,6 +19,7 @@ import qualified Network.HTTP.Client as HTTP import System.Exit import System.FilePath import System.IO +import System.IO.Temp import Testlib.Prekeys -- | Initialised once per test. @@ -26,8 +31,10 @@ data Env = Env manager :: HTTP.Manager, serviceConfigsDir :: FilePath, servicesCwdBase :: Maybe FilePath, + removalKeyPath :: FilePath, prekeys :: IORef [(Int, String)], - lastPrekeys :: IORef [String] + lastPrekeys :: IORef [String], + mls :: IORef MLSState } -- | Initialised once per testsuite. @@ -38,7 +45,8 @@ data GlobalEnv = GlobalEnv gDefaultAPIVersion :: Int, gManager :: HTTP.Manager, gServiceConfigsDir :: FilePath, - gServicesCwdBase :: Maybe FilePath + gServicesCwdBase :: Maybe FilePath, + gRemovalKeyPath :: FilePath } data IntegrationConfig = IntegrationConfig @@ -132,13 +140,15 @@ mkGlobalEnv cfgFile = do gDefaultAPIVersion = 4, gManager = manager, gServiceConfigsDir = configsDir, - gServicesCwdBase = devEnvProjectRoot <&> ( "services") + gServicesCwdBase = devEnvProjectRoot <&> ( "services"), + gRemovalKeyPath = error "Uninitialised removal key path" } -mkEnv :: GlobalEnv -> IO Env +mkEnv :: GlobalEnv -> Codensity IO Env mkEnv ge = do - pks <- newIORef (zip [1 ..] somePrekeys) - lpks <- newIORef someLastPrekeys + pks <- liftIO $ newIORef (zip [1 ..] somePrekeys) + lpks <- liftIO $ newIORef someLastPrekeys + mls <- liftIO . newIORef =<< mkMLSState pure Env { serviceMap = gServiceMap ge, @@ -148,6 +158,40 @@ mkEnv ge = do manager = gManager ge, serviceConfigsDir = gServiceConfigsDir ge, servicesCwdBase = gServicesCwdBase ge, + removalKeyPath = gRemovalKeyPath ge, prekeys = pks, - lastPrekeys = lpks + lastPrekeys = lpks, + mls = mls } + +data MLSState = MLSState + { baseDir :: FilePath, + members :: Set ClientIdentity, + -- | users expected to receive a welcome message after the next commit + newMembers :: Set ClientIdentity, + groupId :: Maybe String, + convId :: Maybe Value, + clientGroupState :: Map ClientIdentity ByteString, + epoch :: Word64 + } + +mkMLSState :: Codensity IO MLSState +mkMLSState = Codensity $ \k -> + withSystemTempDirectory "mls" $ \tmp -> do + k + MLSState + { baseDir = tmp, + members = mempty, + newMembers = mempty, + groupId = Nothing, + convId = Nothing, + clientGroupState = mempty, + epoch = 0 + } + +data ClientIdentity = ClientIdentity + { domain :: String, + user :: String, + client :: String + } + deriving (Eq, Ord) diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 1a5d73c437..5c3cd0bb3e 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -4,6 +4,7 @@ import qualified Control.Exception as E import Control.Monad.Reader import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI @@ -38,6 +39,15 @@ addJSON obj req = : HTTP.requestHeaders req } +addMLS :: ByteString -> HTTP.Request -> HTTP.Request +addMLS bytes req = + req + { HTTP.requestBody = HTTP.RequestBodyLBS (L.fromStrict bytes), + HTTP.requestHeaders = + (fromString "Content-Type", fromString "message/mls") + : HTTP.requestHeaders req + } + addHeader :: String -> String -> HTTP.Request -> HTTP.Request addHeader name value req = req {HTTP.requestHeaders = (CI.mk . C8.pack $ name, C8.pack value) : HTTP.requestHeaders req} diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index cc7f0270e2..df3d9e1a45 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -18,6 +18,7 @@ import qualified Data.Scientific as Sci import Data.String import qualified Data.Text as T import GHC.Stack +import Testlib.Env import Testlib.Types -- | All library functions should use this typeclass for all untyped value @@ -263,13 +264,13 @@ objQid ob = do Nothing -> firstSuccess xs Just y -> pure (Just y) --- Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that +-- | Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that. objQidObject :: HasCallStack => MakesValue a => a -> App Value objQidObject o = do (domain, id_) <- objQid o pure $ object ["domain" .= domain, "id" .= id_] --- Get "domain" field or - if already string-like return String +-- Get "domain" field or - if already string-like - return String. objDomain :: (HasCallStack, MakesValue a) => a -> App String objDomain x = do v <- make x @@ -277,3 +278,59 @@ objDomain x = do Object _ob -> fst <$> objQid v String t -> pure (T.unpack t) other -> assertFailureWithJSON other (typeWasExpectedButGot "Object or String" other) + +-- | Get conversation ID and optional subconversation ID. +-- +-- This accepts subconversation objects in the format: +-- @ +-- { "parent_qualified_id": { +-- "domain": "example.com", +-- "id": "7b6c21d1-322d-4be6-a923-85225691f398" +-- }, +-- "subconv_id": "conference" +-- } +-- @ +-- +-- as well as conversation objects in the general format supported by 'objQid'. +-- Conversation objects can optionally contain a @subconv_id@ field. So, in +-- particular, a flat subconversation format, like +-- @ +-- { "domain": "example.com", +-- "id": "7b6c21d1-322d-4be6-a923-85225691f398", +-- "subconv_id": "conference" +-- } +-- @ +-- is also supported. +objSubConv :: (HasCallStack, MakesValue a) => a -> App (Value, Maybe String) +objSubConv x = do + mParent <- lookupField x "parent_qualified_id" + case mParent of + Nothing -> do + obj <- objQidObject x + subValue <- lookupField x "subconv_id" + sub <- traverse asString subValue + pure (obj, sub) + Just parent -> do + obj <- objQidObject parent + sub <- x %. "subconv_id" & asString + pure (obj, Just sub) + +-- | Turn an object parseable by 'objSubConv' into a canonical flat representation. +objSubConvObject :: (HasCallStack, MakesValue a) => a -> App Value +objSubConvObject x = do + (convId, mSubConvId) <- objSubConv x + (domain, id_) <- objQid convId + pure . object $ + [ "domain" .= domain, + "id" .= id_ + ] + <> ["subconv_id" .= sub | sub <- toList mSubConvId] + +instance MakesValue ClientIdentity where + make cid = + pure $ + object + [ "domain" .= cid.domain, + "id" .= cid.user, + "client_id" .= cid.client + ] diff --git a/integration/test/Testlib/Run.hs b/integration/test/Testlib/Run.hs index e22a998644..05bdce0576 100644 --- a/integration/test/Testlib/Run.hs +++ b/integration/test/Testlib/Run.hs @@ -3,15 +3,22 @@ module Testlib.Run (main, mainI) where import Control.Concurrent import Control.Exception as E import Control.Monad +import Control.Monad.Codensity +import Control.Monad.IO.Class +import Control.Monad.Reader import Data.Foldable +import Data.Function import Data.Functor import Data.List import Data.Time.Clock import RunAllTests import System.Directory import System.Environment +import System.FilePath +import Testlib.App import Testlib.Assertions import Testlib.Env +import Testlib.JSON import Testlib.Options import Testlib.Printing import Testlib.Types @@ -30,20 +37,16 @@ instance Semigroup TestReport where instance Monoid TestReport where mempty = TestReport 0 mempty -runTest :: GlobalEnv -> App () -> IO (Maybe String) -runTest ge action = do +runTest :: GlobalEnv -> App a -> IO (Either String a) +runTest ge action = lowerCodensity $ do env <- mkEnv ge - (runAppWithEnv env action $> Nothing) - `E.catches` [ E.Handler - ( \(e :: AssertionFailure) -> do - Just <$> printFailureDetails e - ), - E.Handler - ( \(e :: SomeException) -> do - putStrLn "exception handler" - pure (Just (colored yellow (displayException e))) - ) - ] + liftIO $ + (Right <$> runAppWithEnv env action) + `E.catches` [ E.Handler -- AssertionFailure + (fmap Left . printFailureDetails), + E.Handler + (fmap Left . printExceptionDetails) + ] pluralise :: Int -> String -> String pluralise 1 x = x @@ -54,7 +57,9 @@ printReport report = do unless (null report.failures) $ putStrLn $ "----------" putStrLn $ show report.count <> " " <> pluralise report.count "test" <> " run." unless (null report.failures) $ do - putStrLn $ colored red "\nFailed tests: " + putStrLn "" + let numFailures = length report.failures + putStrLn $ colored red (show numFailures <> " failed " <> pluralise numFailures "test" <> ": ") for_ report.failures $ \name -> putStrLn $ " - " <> name @@ -102,15 +107,27 @@ main = do let f = testFilter opts cfg = opts.configFile - env <- mkGlobalEnv cfg + genv0 <- mkGlobalEnv cfg + + -- save removal key to a file + genv <- lowerCodensity $ do + env <- mkEnv genv0 + liftIO . runAppWithEnv env $ do + config <- readServiceConfig Galley + relPath <- config %. "settings.mlsPrivateKeyPaths.removal.ed25519" & asString + path <- + asks (.servicesCwdBase) <&> \case + Nothing -> relPath + Just dir -> dir "galley" relPath + pure genv0 {gRemovalKeyPath = path} withAsync displayOutput $ \displayThread -> do report <- fmap mconcat $ pooledForConcurrently tests $ \(name, action) -> do if f name then do - (mErr, tm) <- withTime (runTest env action) + (mErr, tm) <- withTime (runTest genv action) case mErr of - Just err -> do + Left err -> do writeOutput $ "----- " <> name @@ -121,7 +138,7 @@ main = do <> err <> "\n" pure (TestReport 1 [name]) - Nothing -> do + Right _ -> do writeOutput $ name <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n" pure (TestReport 1 []) else pure (TestReport 0 []) diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index eab916158c..e768917e5c 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -11,6 +11,8 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import Data.Functor +import Data.Hex +import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Text as T @@ -64,7 +66,7 @@ prettyResponse r = [ colored yellow "request body:", T.unpack . T.decodeUtf8 $ case Aeson.decode (L.fromStrict b) of Just v -> L.toStrict (Aeson.encodePretty (v :: Aeson.Value)) - Nothing -> b + Nothing -> hex b ], pure $ colored blue "response status: " <> show r.status, pure $ colored blue "response body:", @@ -108,6 +110,24 @@ getServiceMap fedDomain = do env <- ask assertJust ("Could not find service map for federation domain: " <> fedDomain) (Map.lookup fedDomain (env.serviceMap)) +getMLSState :: App MLSState +getMLSState = do + ref <- asks (.mls) + liftIO $ readIORef ref + +setMLSState :: MLSState -> App () +setMLSState s = do + ref <- asks (.mls) + liftIO $ writeIORef ref s + +modifyMLSState :: (MLSState -> MLSState) -> App () +modifyMLSState f = do + ref <- asks (.mls) + liftIO $ modifyIORef ref f + +getBaseDir :: App FilePath +getBaseDir = fmap (.baseDir) getMLSState + data AppFailure = AppFailure String instance Show AppFailure where @@ -133,7 +153,7 @@ assertJust _ (Just x) = pure x assertJust msg Nothing = assertFailure msg addFailureContext :: String -> App a -> App a -addFailureContext msg = modifyFailureMsg (\m -> m <> "\nThis failure happend in this context:\n" <> msg) +addFailureContext msg = modifyFailureMsg (\m -> m <> "\nThis failure happened in this context:\n" <> msg) modifyFailureMsg :: (String -> String) -> App a -> App a modifyFailureMsg modMessage = modifyFailure (\e -> e {msg = modMessage e.msg})