-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2023 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
module Test.LegalHold where

import API.Brig
import API.BrigCommon as BrigC
import qualified API.BrigInternal as BrigI
import API.Common
import API.Galley
import API.GalleyInternal hiding (getConversation)
import Control.Error (MaybeT (MaybeT), runMaybeT)
import Control.Lens ((.~), (^?), (^?!))
import Control.Monad.Extra (findM)
import Control.Monad.Reader (asks, local)
import Control.Monad.Trans.Class (lift)
import Data.Aeson.Lens
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString.Lazy (LazyByteString)
import Data.List.Extra (trim)
import qualified Data.Map as Map
import qualified Data.ProtoLens as Proto
import Data.ProtoLens.Labels ()
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Stack
import MLS.Util
import Network.Wai (Request (pathInfo, requestMethod))
import Notifications
import Numeric.Lens (hex)
import qualified Proto.Otr as Proto
import qualified Proto.Otr_Fields as Proto
import SetupHelpers
import Testlib.MockIntegrationService
import Testlib.Prekeys
import Testlib.Prelude
import UnliftIO (Chan, readChan, timeout)

testLHPreventAddingNonConsentingUsers :: (HasCallStack) => LhApiVersion -> App ()
testLHPreventAddingNonConsentingUsers :: HasCallStack => LhApiVersion -> App ()
testLHPreventAddingNonConsentingUsers LhApiVersion
v = do
  MockServerSettings
-> (Chan (Request, ByteString) -> LiftedApplication)
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall e a.
HasCallStack =>
MockServerSettings
-> (Chan e -> LiftedApplication)
-> ((String, Int) -> Chan e -> App a)
-> App a
withMockServer MockServerSettings
forall a. Default a => a
def (LhApiVersion -> Chan (Request, ByteString) -> LiftedApplication
lhMockAppV LhApiVersion
v) (((String, Int) -> Chan (Request, ByteString) -> App ()) -> App ())
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    (owner, tid, [alice, alex]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
3
    for_ [owner, alice, alex] getSelfConversation

    legalholdWhitelistTeam tid owner >>= assertSuccess
    legalholdIsTeamInWhitelist tid owner >>= assertSuccess
    postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    george <- randomUser OwnDomain def
    georgeQId <- objQidObject george
    hannes <- randomUser OwnDomain def
    hannesQId <- objQidObject hannes
    for_ [george, hannes] getSelfConversation

    connectUsers [alice, george, hannes]
    connectUsers [alex, george, hannes]
    conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201

    -- the guest should be added to the conversation
    bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"conversation.member-join"

    -- assert that the guest is in the conversation
    checkConvHasOtherMembers conv alice [alex, george]

    -- now request legalhold for alex (but not alice)
    requestLegalHoldDevice tid owner alex >>= assertSuccess

    -- the guest should not be removed from the conversation before approving
    checkConvHasOtherMembers conv alice [alex, george]

    -- it should be possible to add the another guest while the LH device is not approved
    addMembers alex conv def {users = [hannesQId]} `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"conversation.member-join"
    checkConvHasOtherMembers conv alice [alex, george, hannes]

    approveLegalHoldDevice tid alex defPassword >>= assertSuccess
    -- the guest should be removed from the conversation
    checkConvHasOtherMembers conv alice [alex]

    -- it should not be possible neither for alex nor for alice to add the guest back
    addMembers alex conv def {users = [georgeQId]}
      >>= assertLabel 403 "not-connected"

    addMembers alice conv def {users = [georgeQId]}
      >>= assertLabel 403 "missing-legalhold-consent"
  where
    checkConvHasOtherMembers :: (HasCallStack) => Value -> Value -> [Value] -> App ()
    checkConvHasOtherMembers :: HasCallStack => Value -> Value -> [Value] -> App ()
checkConvHasOtherMembers Value
conv Value
u [Value]
us =
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
u Value
conv) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        mems <-
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others"
            App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList App [Value] -> ([Value] -> App [Value]) -> App [Value]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> App Value) -> [Value] -> App [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse \Value
m -> do
              Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id"
        mems `shouldMatchSet` forM us (\Value
m -> Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id")

testLHGetAndUpdateSettings :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHGetAndUpdateSettings :: HasCallStack => Consent -> LhApiVersion -> App ()
testLHGetAndUpdateSettings Consent
consent LhApiVersion
v = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  MockServerSettings
-> (Chan (Request, ByteString) -> LiftedApplication)
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall e a.
HasCallStack =>
MockServerSettings
-> (Chan e -> LiftedApplication)
-> ((String, Int) -> Chan e -> App a)
-> App a
withMockServer MockServerSettings
forall a. Default a => a
def (LhApiVersion -> Chan (Request, ByteString) -> LiftedApplication
lhMockAppV LhApiVersion
v) (((String, Int) -> Chan (Request, ByteString) -> App ()) -> App ())
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    (owner, tid, [alice]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
    for_ [owner, alice] getSelfConversation

    stranger <- randomUser dom def
    void $ getSelfConversation stranger

    let getSettingsWorks :: (HasCallStack) => Value -> String -> App ()
        getSettingsWorks Value
target String
status = App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getLegalHoldSettings String
tid Value
target) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
status

        getSettingsFails :: (HasCallStack) => Value -> App ()
        getSettingsFails Value
target = App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getLegalHoldSettings String
tid Value
target) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"no-team-member"

    getSettingsFails stranger
    getSettingsWorks owner "disabled"
    getSettingsWorks alice "disabled"

    whitelistOrEnableLHForTeam consent dom tid owner

    getSettingsFails stranger
    getSettingsWorks owner "not_configured"
    getSettingsWorks alice "not_configured"

    let lhSettings = (String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort
    bindResponse (postLegalHoldSettings tid owner lhSettings) $ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201

    bindResponse (getLegalHoldSettings tid alice) $ \Response
resp ->
      do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        App Value -> String -> App ()
forall a. (HasCallStack, MakesValue a) => a -> String -> App ()
assertFieldMissing Response
resp.json String
"label"
        (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"settings" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"auth_token") App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Value
lhSettings Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"auth_token")
        (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"settings" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"base_url") App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Value
lhSettings Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"base_url")
        (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"settings" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_key" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> String
trim)
          App String -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (Value
lhSettings Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"public_key")
        (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"settings" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"team_id") App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
tid
        (Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"settings" App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"fingerprint" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString App String -> (String -> Int) -> App Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
          App Int -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldNotMatch` (Int
0 :: Int)

testLHMessageExchange ::
  (HasCallStack) =>
  TaggedBool "clients1New" ->
  TaggedBool "clients2New" ->
  App ()
testLHMessageExchange :: HasCallStack =>
TaggedBool "clients1New" -> TaggedBool "clients2New" -> App ()
testLHMessageExchange (TaggedBool Bool
clients1New) (TaggedBool Bool
clients2New) = do
  -- We used to throw LegalholdConflictsOldClients if clients didn't have LH capability, but we
  -- don't do that any more because that broke things.
  -- Related: https://github.com/wireapp/wire-server/pull/4056
  MockServerSettings
-> (Chan (Request, ByteString) -> LiftedApplication)
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall e a.
HasCallStack =>
MockServerSettings
-> (Chan e -> LiftedApplication)
-> ((String, Int) -> Chan e -> App a)
-> App a
withMockServer MockServerSettings
forall a. Default a => a
def Chan (Request, ByteString) -> LiftedApplication
lhMockApp (((String, Int) -> Chan (Request, ByteString) -> App ()) -> App ())
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    (owner, tid, [mem1, mem2]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
3
    for_ [owner, mem1, mem2] getSelfConversation

    let clientSettings :: Bool -> AddClient
        clientSettings Bool
allnew =
          if Bool
allnew
            then AddClient
forall a. Default a => a
def {acapabilities = Just ["legalhold-implicit-consent"]} -- (is should be the default)
            else AddClient
forall a. Default a => a
def {acapabilities = Nothing}
    void $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201
    void $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201

    legalholdWhitelistTeam tid owner >>= assertSuccess
    legalholdIsTeamInWhitelist tid owner >>= assertSuccess
    postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201

    let getClients :: Value -> App [Value]
        getClients Value
mem = do
          res <- Value -> Domain -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
getClientsQualified Value
mem Domain
OwnDomain Value
mem
          val <- getJSON 200 res
          asList val

        assertMessageSendingWorks :: (HasCallStack) => App ()
        assertMessageSendingWorks = do
          clients1 <- Value -> App [Value]
getClients Value
mem1
          clients2 <- getClients mem2

          clientIds1 <- traverse objId clients1
          clientIds2 <- traverse objId clients2

          proteusRecipients <- mkProteusRecipients mem1 [(mem1, clientIds1), (mem2, clientIds2)] "hey there"

          let proteusMsg String
senderClient =
                forall msg. Message msg => msg
Proto.defMessage @Proto.QualifiedNewOtrMessage
                  QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& (ClientId -> Identity ClientId)
-> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage
#sender ((ClientId -> Identity ClientId)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> ((Word64 -> Identity Word64) -> ClientId -> Identity ClientId)
-> (Word64 -> Identity Word64)
-> QualifiedNewOtrMessage
-> Identity QualifiedNewOtrMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Identity Word64) -> ClientId -> Identity ClientId
forall (f :: * -> *) s a.
(Functor f, HasField s "client" a) =>
LensLike' f s a
Proto.client ((Word64 -> Identity Word64)
 -> QualifiedNewOtrMessage -> Identity QualifiedNewOtrMessage)
-> Word64 -> QualifiedNewOtrMessage -> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (String
senderClient String -> Getting (Endo Word64) String Word64 -> Word64
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Word64) String Word64
forall a. Integral a => Prism' String a
Prism' String Word64
hex)
                  QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
#recipients ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  [QualifiedUserEntry]
  [QualifiedUserEntry]
-> [QualifiedUserEntry]
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [QualifiedUserEntry
proteusRecipients]
                  QualifiedNewOtrMessage
-> (QualifiedNewOtrMessage -> QualifiedNewOtrMessage)
-> QualifiedNewOtrMessage
forall a b. a -> (a -> b) -> b
& ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
#reportAll ASetter
  QualifiedNewOtrMessage
  QualifiedNewOtrMessage
  ClientMismatchStrategy'ReportAll
  ClientMismatchStrategy'ReportAll
-> ClientMismatchStrategy'ReportAll
-> QualifiedNewOtrMessage
-> QualifiedNewOtrMessage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ClientMismatchStrategy'ReportAll
forall msg. Message msg => msg
Proto.defMessage

              sender [s]
clients =
                let senderClient :: s
senderClient = [s] -> s
forall a. HasCallStack => [a] -> a
head ([s] -> s) -> [s] -> s
forall a b. (a -> b) -> a -> b
$ (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (\s
c -> s
c s -> Getting (First Value) s Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' s Value
forall t. AsValue t => Key -> Traversal' t Value
key (String -> Key
forall a. IsString a => String -> a
fromString String
"type") Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value -> Maybe Value
forall a. a -> Maybe a
Just (String -> Value
forall a. ToJSON a => a -> Value
toJSON String
"legalhold")) [s]
clients
                 in Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ s
senderClient s -> Getting (Endo Text) s Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Key -> Traversal' s Value
forall t. AsValue t => Key -> Traversal' t Value
key (String -> Key
forall a. IsString a => String -> a
fromString String
"id") ((Value -> Const (Endo Text) Value) -> s -> Const (Endo Text) s)
-> ((Text -> Const (Endo Text) Text)
    -> Value -> Const (Endo Text) Value)
-> Getting (Endo Text) s Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo Text) Text)
-> Value -> Const (Endo Text) Value
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
          postProteusMessage mem1 (conv %. "qualified_id") (proteusMsg (sender clients1)) >>= assertSuccess
          postProteusMessage mem2 (conv %. "qualified_id") (proteusMsg (sender clients2)) >>= assertSuccess

    assertMessageSendingWorks

    requestLegalHoldDevice tid owner mem1 >>= assertSuccess
    assertMessageSendingWorks

    requestLegalHoldDevice tid owner mem2 >>= assertSuccess
    assertMessageSendingWorks

    approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess
    fmap length (getClients mem1) `shouldMatchInt` 2
    assertMessageSendingWorks

    approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess
    fmap length (getClients mem2) `shouldMatchInt` 2
    assertMessageSendingWorks

data TestClaimKeys
  = TCKConsentMissing -- (team not whitelisted, that is)
  | TCKConsentAndNewClients
  deriving (Int -> TestClaimKeys -> String -> String
[TestClaimKeys] -> String -> String
TestClaimKeys -> String
(Int -> TestClaimKeys -> String -> String)
-> (TestClaimKeys -> String)
-> ([TestClaimKeys] -> String -> String)
-> Show TestClaimKeys
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestClaimKeys -> String -> String
showsPrec :: Int -> TestClaimKeys -> String -> String
$cshow :: TestClaimKeys -> String
show :: TestClaimKeys -> String
$cshowList :: [TestClaimKeys] -> String -> String
showList :: [TestClaimKeys] -> String -> String
Show, (forall x. TestClaimKeys -> Rep TestClaimKeys x)
-> (forall x. Rep TestClaimKeys x -> TestClaimKeys)
-> Generic TestClaimKeys
forall x. Rep TestClaimKeys x -> TestClaimKeys
forall x. TestClaimKeys -> Rep TestClaimKeys x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestClaimKeys -> Rep TestClaimKeys x
from :: forall x. TestClaimKeys -> Rep TestClaimKeys x
$cto :: forall x. Rep TestClaimKeys x -> TestClaimKeys
to :: forall x. Rep TestClaimKeys x -> TestClaimKeys
Generic)

data LHApprovedOrPending
  = LHApproved
  | LHPending
  deriving (Int -> LHApprovedOrPending -> String -> String
[LHApprovedOrPending] -> String -> String
LHApprovedOrPending -> String
(Int -> LHApprovedOrPending -> String -> String)
-> (LHApprovedOrPending -> String)
-> ([LHApprovedOrPending] -> String -> String)
-> Show LHApprovedOrPending
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LHApprovedOrPending -> String -> String
showsPrec :: Int -> LHApprovedOrPending -> String -> String
$cshow :: LHApprovedOrPending -> String
show :: LHApprovedOrPending -> String
$cshowList :: [LHApprovedOrPending] -> String -> String
showList :: [LHApprovedOrPending] -> String -> String
Show, (forall x. LHApprovedOrPending -> Rep LHApprovedOrPending x)
-> (forall x. Rep LHApprovedOrPending x -> LHApprovedOrPending)
-> Generic LHApprovedOrPending
forall x. Rep LHApprovedOrPending x -> LHApprovedOrPending
forall x. LHApprovedOrPending -> Rep LHApprovedOrPending x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LHApprovedOrPending -> Rep LHApprovedOrPending x
from :: forall x. LHApprovedOrPending -> Rep LHApprovedOrPending x
$cto :: forall x. Rep LHApprovedOrPending x -> LHApprovedOrPending
to :: forall x. Rep LHApprovedOrPending x -> LHApprovedOrPending
Generic)

-- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients.
testLHClaimKeys :: LHApprovedOrPending -> TestClaimKeys -> App ()
testLHClaimKeys :: LHApprovedOrPending -> TestClaimKeys -> App ()
testLHClaimKeys LHApprovedOrPending
approvedOrPending TestClaimKeys
testmode = do
  MockServerSettings
-> (Chan (Request, ByteString) -> LiftedApplication)
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall e a.
HasCallStack =>
MockServerSettings
-> (Chan e -> LiftedApplication)
-> ((String, Int) -> Chan e -> App a)
-> App a
withMockServer MockServerSettings
forall a. Default a => a
def Chan (Request, ByteString) -> LiftedApplication
lhMockApp (((String, Int) -> Chan (Request, ByteString) -> App ()) -> App ())
-> ((String, Int) -> Chan (Request, ByteString) -> App ())
-> App ()
forall a b. (a -> b) -> a -> b
$ \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    (lowner, ltid, [lmem]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
    (powner, ptid, [pmem]) <- createTeam OwnDomain 2
    for_ [lowner, lmem, powner, pmem] getSelfConversation

    legalholdWhitelistTeam ltid lowner >>= assertSuccess
    legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess
    postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201

    requestLegalHoldDevice ltid lowner lmem >>= assertSuccess
    case approvedOrPending of
      LHApprovedOrPending
LHApproved -> String -> App Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
ltid (Value
lmem Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
      LHApprovedOrPending
LHPending -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    let addc Maybe [String]
caps = Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
pmem (Maybe [String] -> AddClient
settings Maybe [String]
caps) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
        settings Maybe [String]
caps =
          AddClient
forall a. Default a => a
def
            { prekeys = Just $ take 10 somePrekeysRendered,
              lastPrekey = Just $ head someLastPrekeysRendered,
              acapabilities = caps
            }
     in addc $ Just ["legalhold-implicit-consent"]

    case testmode of
      TestClaimKeys
TCKConsentMissing -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TestClaimKeys
TCKConsentAndNewClients -> do
        String -> Value -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdWhitelistTeam String
ptid Value
powner App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
        String -> Value -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdIsTeamInWhitelist String
ptid Value
powner App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess

    llhdevs :: [String] <- do
      let getCls :: Value -> App [String]
          getCls Value
mem = do
            res <- Value -> Domain -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
getClientsQualified Value
mem Domain
OwnDomain Value
mem
            val <- getJSON 200 res
            cls <- asList val
            objId `mapM` cls
      getCls lmem

    let assertResp :: (HasCallStack) => Response -> App ()
        assertResp Response
resp = case (TestClaimKeys
testmode, [String]
llhdevs) of
          (TestClaimKeys
TCKConsentMissing, (String
_ : [String]
_)) -> do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
403
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"missing-legalhold-consent"
          (TestClaimKeys
TCKConsentAndNewClients, (String
_ : [String]
_)) -> do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          (TestClaimKeys
_, []) -> do
            -- no lh devices: no reason to be shy!
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) assertResp
    case llhdevs of
      [String
llhdev] ->
        -- retrieve lh client if /a
        App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (Value -> App Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
getUsersPrekeysClient Value
pmem (Value
lmem Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") String
llhdev) HasCallStack => Response -> App ()
Response -> App ()
assertResp
      [] ->
        -- we're probably doing the LHPending thing right now
        () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      bad :: [String]
bad@(String
_ : String
_ : [String]
_) ->
        -- fail if there is more than one.
        String -> App ()
forall a. HasCallStack => String -> App a
assertFailure (String
"impossible -- more than one LH device: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
bad)

    slmemdom <- asString $ lmem %. "qualified_id.domain"
    slmemid <- asString $ lmem %. "qualified_id.id"
    let userClients = [(String, Map String (Set String))]
-> Map String (Map String (Set String))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
slmemdom, [(String, Set String)] -> Map String (Set String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
slmemid, [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
llhdevs)])]
    bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp

testLHAddClientManually :: App ()
testLHAddClientManually :: App ()
testLHAddClientManually = do
  (_owner, _tid, [mem1]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [_owner, mem1] getSelfConversation

  bindResponse (addClient mem1 def {ctype = "legalhold"}) $ \Response
resp -> do
    HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
400 String
"client-error" Response
resp
    -- we usually don't test the human-readable "message", but in this case it is important to
    -- make sure the reason is the right one, and not eg. "LH service not present", or some
    -- other unspecific client error.
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"message" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"LegalHold clients cannot be added manually. LegalHold must be enabled on this user by an admin"

testLHDeleteClientManually :: App ()
testLHDeleteClientManually :: App ()
testLHDeleteClientManually = do
  (_owner, _tid, [mem1]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [_owner, mem1] getSelfConversation

  cid <- bindResponse (BrigI.addClient mem1 def {ctype = "legalhold"}) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
    Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Value -> App String) -> App Value -> App String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id"
  bindResponse (deleteClient mem1 cid) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
400
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"client-error"
    -- we usually don't test the human-readable "message", but in this case it is important to
    -- make sure the reason is the right one, and not eg. "LH service not present", or some
    -- other unspecific client error.
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"message" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"LegalHold clients cannot be deleted. LegalHold must be disabled on this user by an admin"

testLHRequestDevice :: Consent -> LhApiVersion -> App ()
testLHRequestDevice :: Consent -> LhApiVersion -> App ()
testLHRequestDevice Consent
consent LhApiVersion
v = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  (alice, tid, [bob]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
  for_ [alice, bob] getSelfConversation

  let reqNotEnabled Value
requester Value
requestee =
        String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
requester Value
requestee
          App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"legalhold-not-enabled"

  reqNotEnabled alice bob

  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  withMockServer def (lhMockAppWithPrekeys v MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    let statusShouldBe :: (HasCallStack) => String -> App ()
        statusShouldBe :: HasCallStack => String -> App ()
statusShouldBe String
status =
          String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
            Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
status

    -- the user has not agreed to be under legalhold
    [Value] -> (Value -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Value
alice, Value
bob] \Value
requester -> do
      Value -> Value -> App ()
reqNotEnabled Value
requester Value
bob
      HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"no_consent"

    Consent -> String -> String -> Value -> App ()
forall tid user dom.
(HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) =>
Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam Consent
consent String
dom String
tid Value
alice
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe case Consent
consent of
      Consent
Implicit -> String
"disabled"
      Consent
Explicit -> String
"no_consent"

    let expected :: Int
expected = case Consent
consent of
          Consent
Implicit -> Int
204
          Consent
Explicit -> Int
201
     in String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
consentToLegalHold String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
expected
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"pending"

    -- requesting twice should be idempotent wrt the approval
    -- mind that requesting twice means two "user.legalhold-request" notifications
    -- for the clients of the user under legalhold (bob)
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
204
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"pending"

    [bobc1, bobc2] <- Int -> App String -> App [String]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 do
      App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
bob AddClient
forall a. Default a => a
def App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
    for_ [bobc1, bobc2] \String
client ->
      Value -> String -> Maybe Value -> (Value -> App Bool) -> App Value
forall user client lastNotifId.
(HasCallStack, MakesValue user, MakesValue client,
 MakesValue lastNotifId) =>
user
-> client -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotificationClient Value
bob String
client Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserLegalholdRequestNotif App Value -> (Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
notif -> do
        Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.last_prekey" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
lpk
        Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.id" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob

-- | pops a channel until it finds an event that returns a 'Just'
--   upon running the matcher function
checkChan :: (HasCallStack) => Chan t -> (t -> App (Maybe a)) -> App a
checkChan :: forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan t
chan t -> App (Maybe a)
match = do
  tSecs <- (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) (Int -> Int) -> (Env -> Int) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Int
timeOutSeconds)

  maybe (assertFailure "checkChan: timed out") pure =<< timeout tSecs do
    let go = Chan t -> App t
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan t
chan App t -> (t -> App (Maybe a)) -> App (Maybe a)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> App (Maybe a)
match App (Maybe a) -> (Maybe a -> App a) -> App a
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= App a -> (a -> App a) -> Maybe a -> App a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe App a
go a -> App a
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    go

-- | like 'checkChan' but throws away the request and decodes the body
checkChanVal :: (HasCallStack) => Chan (t, LazyByteString) -> (Value -> MaybeT App a) -> App a
checkChanVal :: forall t a.
HasCallStack =>
Chan (t, ByteString) -> (Value -> MaybeT App a) -> App a
checkChanVal Chan (t, ByteString)
chan Value -> MaybeT App a
match = Chan (t, ByteString) -> ((t, ByteString) -> App (Maybe a)) -> App a
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (t, ByteString)
chan \(t
_, ByteString
bs) -> MaybeT App a -> App (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  App (Maybe Value) -> MaybeT App Value
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe Value -> App (Maybe Value)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bs)) MaybeT App Value -> (Value -> MaybeT App a) -> MaybeT App a
forall a b. MaybeT App a -> (a -> MaybeT App b) -> MaybeT App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> MaybeT App a
match

testLHApproveDevice :: Consent -> App ()
testLHApproveDevice :: Consent -> App ()
testLHApproveDevice Consent
consent = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  -- team users
  -- alice (boss) and bob and charlie (member)
  (alice, tid, [bob, charlie]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
3
  for_ [alice, bob, charlie] getSelfConversation

  -- ollie the outsider
  ollie <- do
    o <- randomUser dom def
    connectTwoUsers o alice
    pure o

  -- sandy the stranger
  sandy <- randomUser dom def
  for_ [ollie, sandy] getSelfConversation

  whitelistOrEnableLHForTeam consent dom tid alice
  approveLegalHoldDevice tid (bob %. "qualified_id") defPassword
    >>= assertLabel 412 "legalhold-not-pending"

  withMockServer def lhMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort)
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    let expected :: Int
expected = case Consent
consent of
          Consent
Implicit -> Int
204
          Consent
Explicit -> Int
201
     in String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
consentToLegalHold String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
expected
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    let uidsAndTidMatch :: Value -> MaybeT App ()
uidsAndTidMatch Value
val = do
          actualTid <-
            Value -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM Value
val String
"team_id"
              MaybeT App Value
-> (Value -> MaybeT App String) -> MaybeT App String
forall a b. MaybeT App a -> (a -> MaybeT App b) -> MaybeT App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= App String -> MaybeT App String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
              (App String -> MaybeT App String)
-> (Value -> App String) -> Value -> MaybeT App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
          actualUid <-
            lookupFieldM val "user_id"
              >>= lift
              . asString
          bobUid <- lift $ objId bob

          -- we pass the check on equality
          unless ((actualTid, actualUid) == (tid, bobUid)) do
            mzero

    Chan (Request, ByteString) -> (Value -> MaybeT App ()) -> App ()
forall t a.
HasCallStack =>
Chan (t, ByteString) -> (Value -> MaybeT App a) -> App a
checkChanVal Chan (Request, ByteString)
chan Value -> MaybeT App ()
uidsAndTidMatch

    -- the team owner cannot approve for bob
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
approveLegalHoldDevice' String
tid Value
alice Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"
    -- bob needs to provide a password
    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
"wrong-password"
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"
    -- now bob finally found his password
    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    let matchAuthToken :: a -> MaybeT App String
matchAuthToken a
val =
          a -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM a
val String
"refresh_token"
            MaybeT App Value
-> (Value -> MaybeT App String) -> MaybeT App String
forall a b. MaybeT App a -> (a -> MaybeT App b) -> MaybeT App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= App String -> MaybeT App String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (App String -> MaybeT App String)
-> (Value -> App String) -> Value -> MaybeT App String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString

    Chan (Request, ByteString)
-> (Value -> MaybeT App String) -> App String
forall t a.
HasCallStack =>
Chan (t, ByteString) -> (Value -> MaybeT App a) -> App a
checkChanVal Chan (Request, ByteString)
chan Value -> MaybeT App String
forall {a}. MakesValue a => a -> MaybeT App String
matchAuthToken
      App String -> (String -> App Response) -> App Response
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> String -> App Response
forall uid.
(HasCallStack, MakesValue uid) =>
uid -> String -> App Response
renewToken Value
bob
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    lhdId <- Value -> App String
forall user. MakesValue user => user -> App String
lhDeviceIdOf Value
bob

    legalholdUserStatus tid alice bob `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
lhdId
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

    replicateM 2 do
      objId $ addClient bob def `bindResponse` getJSON 201
      >>= traverse_ \String
client ->
        Value -> String -> Maybe Value -> (Value -> App Bool) -> App Value
forall user client lastNotifId.
(HasCallStack, MakesValue user, MakesValue client,
 MakesValue lastNotifId) =>
user
-> client -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotificationClient Value
bob String
client Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserClientAddNotif App Value -> (Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
notif -> do
          Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.client.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"legalhold"
          Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.client.class" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"legalhold"

    -- the other team members receive a notification about the
    -- legalhold device being approved in their team
    for_ [alice, charlie] \Value
user -> do
      Value -> Maybe Value -> (Value -> App Bool) -> App Value
forall user lastNotifId.
(HasCallStack, MakesValue user, MakesValue lastNotifId) =>
user -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotification Value
user Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserLegalholdEnabledNotif App Value -> (Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
notif -> do
        Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.id" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
    for_ [ollie, sandy] \Value
outsider -> do
      outsiderClient <- App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ Value -> AddClient -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> AddClient -> App Response
addClient Value
outsider AddClient
forall a. Default a => a
def App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
      assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif

testLHGetDeviceStatus :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHGetDeviceStatus :: HasCallStack => Consent -> LhApiVersion -> App ()
testLHGetDeviceStatus Consent
consent LhApiVersion
v = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
  for_ [alice, bob] getSelfConversation

  for_ [alice, bob] \Value
user -> do
    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
user App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"no_consent"

  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  withMockServer
    def
    do lhMockAppWithPrekeys v MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}
    \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
      Consent -> String -> String -> Value -> App ()
forall tid user dom.
(HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) =>
Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam Consent
consent String
dom String
tid Value
alice
      String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` case Consent
consent of
          Consent
Implicit -> String
"disabled"
          Consent
Explicit -> String
"no_consent"

        App Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField Response
resp.json String
"last_prekey"
          App (Maybe Value) -> (Maybe Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Value -> App ()
forall a. HasCallStack => Maybe a -> App ()
assertNothing
        MaybeT App Value -> App (Maybe Value)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (App Value -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM Response
resp.json String
"client" MaybeT App Value -> (Value -> MaybeT App Value) -> MaybeT App Value
forall a b. MaybeT App a -> (a -> MaybeT App b) -> MaybeT App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> String -> MaybeT App Value)
-> String -> Value -> MaybeT App Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> String -> MaybeT App Value
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> MaybeT App Value
lookupFieldM String
"id")
          App (Maybe Value) -> (Maybe Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Value -> App ()
forall a. HasCallStack => Maybe a -> App ()
assertNothing

      -- the status messages for these have already been tested
      String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort)
        App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

      let expected :: Int
expected = case Consent
consent of
            Consent
Implicit -> Int
204
            Consent
Explicit -> Int
201
       in String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
consentToLegalHold String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
expected
      String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob
        App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

      String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
defPassword
        App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

      lhdId <- Value -> App String
forall user. MakesValue user => user -> App String
lhDeviceIdOf Value
bob
      legalholdUserStatus tid alice bob `bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"last_prekey" App Value -> Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value
lpk
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"client.id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
lhdId

      requestLegalHoldDevice tid alice bob
        >>= assertLabel 409 "legalhold-already-enabled"

-- | this sets the timeout to a higher number; we need
--   this because the SQS queue on the brig is super slow
--   and that's why client.remove events arrive really late
--
--   FUTUREWORK(mangoiv): improve the speed of internal
--   event queuing
setTimeoutTo :: Int -> Env -> Env
setTimeoutTo :: Int -> Env -> Env
setTimeoutTo Int
tSecs Env
env = Env
env {timeOutSeconds = tSecs}

testLHDisableForUser :: (HasCallStack) => Consent -> App ()
testLHDisableForUser :: HasCallStack => Consent -> App ()
testLHDisableForUser Consent
consent = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  (alice, tid, [bob]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
  for_ [alice, bob] getSelfConversation

  withMockServer def lhMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
chan -> do
    Consent
-> String -> String -> Value -> Value -> (String, Int) -> App ()
forall dom tid owner uid.
(HasCallStack, MakesValue dom, MakesValue tid, MakesValue owner,
 MakesValue uid) =>
Consent -> dom -> tid -> owner -> uid -> (String, Int) -> App ()
setUpLHDevice Consent
consent String
dom String
tid Value
alice Value
bob (String, Int)
lhDomAndPort

    Value -> Maybe Value -> (Value -> App Bool) -> App Value
forall user lastNotifId.
(HasCallStack, MakesValue user, MakesValue lastNotifId) =>
user -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotification Value
bob Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserClientAddNotif App Value -> (Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
notif -> do
      Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.client.type" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"legalhold"
      Value
notif Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.client.class" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"legalhold"

    -- only an admin can disable legalhold
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
bob Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"operation-denied"

    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
alice Value
bob String
"fix ((\"the password always is \" <>) . show)"
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"

    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
alice Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
_) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      Bool -> MaybeT App () -> MaybeT App ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        do
          ByteString -> String
BS8.unpack Request
req.requestMethod
            String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"POST"
            Bool -> Bool -> Bool
&& Request
req.pathInfo
            [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"remove"])
        MaybeT App ()
forall a. MaybeT App a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    App Value -> App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (App Value -> App ()) -> App Value -> App ()
forall a b. (a -> b) -> a -> b
$ (Env -> Env) -> App Value -> App Value
forall a. (Env -> Env) -> App a -> App a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Int -> Env -> Env
setTimeoutTo Int
90) do
      Value -> Maybe Value -> (Value -> App Bool) -> App Value
forall user lastNotifId.
(HasCallStack, MakesValue user, MakesValue lastNotifId) =>
user -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotification Value
bob Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserClientRemoveNotif
        App Value -> App Value -> App Value
forall a b. App a -> App b -> App b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Value -> Maybe Value -> (Value -> App Bool) -> App Value
forall user lastNotifId.
(HasCallStack, MakesValue user, MakesValue lastNotifId) =>
user -> Maybe lastNotifId -> (Value -> App Bool) -> App Value
awaitNotification Value
bob Maybe Value
noValue Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isUserLegalholdDisabledNotif

    bobId <- Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
    lhClients <-
      BrigI.getClientsFull bob [bobId] `bindResponse` \Response
resp -> do
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
bobId
          App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
            App [Value] -> ([Value] -> App [Value]) -> App [Value]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> App Bool) -> [Value] -> App [Value]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM \Value
val -> (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"legalhold") (String -> Bool) -> App String -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value
val Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"type" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString)

    shouldBeEmpty lhClients

testLHEnablePerTeam :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHEnablePerTeam :: HasCallStack => Consent -> LhApiVersion -> App ()
testLHEnablePerTeam Consent
consent LhApiVersion
v = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
  for_ [alice, bob] getSelfConversation

  legalholdIsEnabled tid alice `bindResponse` \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"lockStatus" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"unlocked"
    Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"

  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    Consent
-> String -> String -> Value -> Value -> (String, Int) -> App ()
forall dom tid owner uid.
(HasCallStack, MakesValue dom, MakesValue tid, MakesValue owner,
 MakesValue uid) =>
Consent -> dom -> tid -> owner -> uid -> (String, Int) -> App ()
setUpLHDevice Consent
consent String
dom String
tid Value
alice Value
bob (String, Int)
lhDomAndPort

    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

      String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
putLegalholdStatus String
tid Value
alice String
"disabled"
        App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` case Consent
consent of
          Consent
Implicit -> HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"legalhold-whitelisted-only"
          Consent
Explicit -> HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    -- the put doesn't have any influence on the status being "enabled"
    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` case Consent
consent of
        Consent
Implicit -> String
"enabled"
        Consent
Explicit -> String
"disabled"

testLHGetMembersIncludesStatus :: LhApiVersion -> App ()
testLHGetMembersIncludesStatus :: LhApiVersion -> App ()
testLHGetMembersIncludesStatus LhApiVersion
v = do
  -- team users
  -- alice (team owner) and bob (member)
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, bob] getSelfConversation

  let statusShouldBe :: String -> App ()
      statusShouldBe String
status = do
        Value -> String -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getTeamMembers Value
alice String
tid App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          [bobMember] <-
            Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members"
              App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList App [Value] -> ([Value] -> App [Value]) -> App [Value]
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> App Bool) -> [Value] -> App [Value]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM \Value
u -> do
                String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool) -> App String -> App (String -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (Value
u Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"user") App (String -> Bool) -> App String -> App Bool
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
          bobMember %. "legalhold_status" `shouldMatch` status

  statusShouldBe "no_consent"
  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> App ()
statusShouldBe String
"no_consent"

    String -> Value -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdWhitelistTeam String
tid Value
alice
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    -- the status messages for these have already been tested
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort)
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    -- legalhold has been requested but is disabled
    String -> App ()
statusShouldBe String
"disabled"

    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    -- legalhold has been set to pending after requesting device
    String -> App ()
statusShouldBe String
"pending"

    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    -- bob has accepted the legalhold device
    String -> App ()
statusShouldBe String
"enabled"

testLHConnectionsWithNonConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithNonConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithNonConsentingUsers LhApiVersion
v = do
  (alice, tid, []) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  bob <- randomUser OwnDomain def
  carl <- randomUser OwnDomain def
  dee <- randomUser OwnDomain def
  for_ [alice, bob, carl, dee] getSelfConversation

  legalholdWhitelistTeam tid alice
    >>= assertStatus 200

  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort)
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
alice
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    -- Connections are not blocked before LH is approved by alice
    Value -> Value -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers Value
alice Value
bob
    bobConvId <- Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConnection Value
alice Value
bob App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation"

    postConnection dee alice >>= assertSuccess
    deeConvId <- getConnection alice dee `bindResponse` \Response
resp -> Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_conversation"

    approveLegalHoldDevice tid alice defPassword
      >>= assertStatus 200

    -- Connections with bob and dee are now in missing-legalhold-consent state
    -- and the 1:1 convs are broken
    assertConnection alice bob "missing-legalhold-consent"
    assertConnection bob alice "missing-legalhold-consent"
    getConversation bob bobConvId
      >>= assertLabel 403 "access-denied"

    assertConnection alice dee "missing-legalhold-consent"
    assertConnection dee alice "missing-legalhold-consent"
    getConversation dee deeConvId
      >>= assertLabel 403 "access-denied"

    -- Connections are blocked after alice approves the LH device
    postConnection carl alice
      >>= assertLabel 403 "missing-legalhold-consent"
    postConnection alice carl
      >>= assertLabel 403 "missing-legalhold-consent"

    disableLegalHold tid alice alice defPassword
      >>= assertStatus 200

    -- Disabling LH restores connection status and 1:1 convs
    assertConnection alice bob "accepted"
    assertConnection bob alice "accepted"
    getConversation bob bobConvId `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others.0.qualified_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
alice

    assertConnection alice dee "pending"
    assertConnection dee alice "sent"
    getConversation dee deeConvId `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others.0.qualified_id" App Value -> App Value -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App Value
forall a. (HasCallStack, MakesValue a) => a -> App Value
objQidObject Value
alice

testLHConnectionsWithConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithConsentingUsers :: LhApiVersion -> App ()
testLHConnectionsWithConsentingUsers LhApiVersion
v = do
  (alice, teamA, []) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  (bob, teamB, [barbara]) <- createTeam OwnDomain 2
  for_ [alice, bob, barbara] getSelfConversation

  legalholdWhitelistTeam teamA alice
    >>= assertStatus 200
  legalholdWhitelistTeam teamB bob
    >>= assertStatus 200

  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
teamA Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort)
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
teamA Value
alice Value
alice
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    -- Connections are not blocked before LH is approved by alice
    Value -> Value -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers Value
alice Value
bob

    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
teamA Value
alice String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    -- Connection with bob is now in whatever state
    Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConnection Value
bob Value
alice App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"accepted"

    -- Connections are not blocked after alice approves the LH device because
    -- teamB has implicit consent
    Value -> Value -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers Value
alice Value
barbara

data GroupConvAdmin
  = LegalholderIsAdmin
  | PeerIsAdmin
  | BothAreAdmins
  deriving (Int -> GroupConvAdmin -> String -> String
[GroupConvAdmin] -> String -> String
GroupConvAdmin -> String
(Int -> GroupConvAdmin -> String -> String)
-> (GroupConvAdmin -> String)
-> ([GroupConvAdmin] -> String -> String)
-> Show GroupConvAdmin
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GroupConvAdmin -> String -> String
showsPrec :: Int -> GroupConvAdmin -> String -> String
$cshow :: GroupConvAdmin -> String
show :: GroupConvAdmin -> String
$cshowList :: [GroupConvAdmin] -> String -> String
showList :: [GroupConvAdmin] -> String -> String
Show, (forall x. GroupConvAdmin -> Rep GroupConvAdmin x)
-> (forall x. Rep GroupConvAdmin x -> GroupConvAdmin)
-> Generic GroupConvAdmin
forall x. Rep GroupConvAdmin x -> GroupConvAdmin
forall x. GroupConvAdmin -> Rep GroupConvAdmin x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GroupConvAdmin -> Rep GroupConvAdmin x
from :: forall x. GroupConvAdmin -> Rep GroupConvAdmin x
$cto :: forall x. Rep GroupConvAdmin x -> GroupConvAdmin
to :: forall x. Rep GroupConvAdmin x -> GroupConvAdmin
Generic)

-- | If a member of an existing conversation is assigned a LH device, users are removed from
-- the conversation until policy conflicts are resolved.
--
-- As to who gets to stay:
-- - admins will stay over members
-- - local members will stay over remote members.
testLHNoConsentRemoveFromGroup :: LHApprovedOrPending -> GroupConvAdmin -> App ()
testLHNoConsentRemoveFromGroup :: LHApprovedOrPending -> GroupConvAdmin -> App ()
testLHNoConsentRemoveFromGroup LHApprovedOrPending
approvedOrPending GroupConvAdmin
admin = do
  (alice, tidAlice, []) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  (bob, tidBob, []) <- createTeam OwnDomain 1
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tidAlice alice >>= assertStatus 200
  withMockServer def lhMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tidAlice Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    [Value] -> ([WebSocket] -> App ()) -> App ()
forall a w.
(HasCallStack, ToWSConnect w) =>
[w] -> ([WebSocket] -> App a) -> App a
withWebSockets [Value
alice, Value
bob] \[WebSocket
aws, WebSocket
bws] -> do
      Value -> Value -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> App ()
connectTwoUsers Value
alice Value
bob
      qConvId <- do
        let (Value
inviter, String
tidInviter, Value
invitee, String
inviteeRole) = case GroupConvAdmin
admin of
              GroupConvAdmin
LegalholderIsAdmin -> (Value
alice, String
tidAlice, Value
bob, String
"wire_member")
              GroupConvAdmin
BothAreAdmins -> (Value
alice, String
tidAlice, Value
bob, String
"wire_admin")
              GroupConvAdmin
PeerIsAdmin -> (Value
bob, String
tidBob, Value
alice, String
"wire_member")

        let createConv :: CreateConv
createConv = CreateConv
defProteus {qualifiedUsers = [invitee], newUsersRole = inviteeRole, team = Just tidInviter}
        Value -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation Value
inviter CreateConv
createConv App Response -> (Response -> App Value) -> App Value
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
          otherMembers <- Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"members.others" App Value -> (App Value -> App [Value]) -> App [Value]
forall a b. a -> (a -> b) -> b
& App Value -> App [Value]
forall a. (HasCallStack, MakesValue a) => a -> App [Value]
asList
          selfMember <- resp.json %. "members.self"
          otherMember <- findM (\Value
m -> Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Value -> Value -> Bool) -> App Value -> App (Value -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value
m Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id" App (Value -> Bool) -> App Value -> App Bool
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value
invitee Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") otherMembers
          selfMember %. "conversation_role" `shouldMatch` "wire_admin"
          otherMember %. "conversation_role" `shouldMatch` case admin of
            GroupConvAdmin
BothAreAdmins -> String
"wire_admin"
            GroupConvAdmin
PeerIsAdmin -> String
"wire_member"
            GroupConvAdmin
LegalholderIsAdmin -> String
"wire_member"
          resp.json %. "qualified_id"
      let convId = Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
qConvId
      for_ [aws, bws] \WebSocket
ws -> do
        HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch Value -> App Bool
forall a. (HasCallStack, MakesValue a) => a -> App Bool
isConvCreateNotifNotSelf WebSocket
ws App Value -> (Value -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
pl -> Value
pl Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"payload.0.conversation" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` App String
convId

      for_ [alice, bob] \Value
user ->
        Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
user Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

      requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201
      case approvedOrPending of
        LHApprovedOrPending
LHApproved -> String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tidAlice Value
alice String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
        LHApprovedOrPending
LHPending -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      legalholdUserStatus tidAlice alice alice `bindResponse` \Response
resp -> do
        Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
        Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` case LHApprovedOrPending
approvedOrPending of
          LHApprovedOrPending
LHApproved -> String
"enabled"
          LHApprovedOrPending
LHPending -> String
"pending"

      case admin of
        GroupConvAdmin
LegalholderIsAdmin -> do
          case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> [WebSocket] -> (WebSocket -> App Value) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WebSocket
aws, WebSocket
bws] do HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (Value -> Value -> App Bool
forall user a.
(HasCallStack, MakesValue user, MakesValue a) =>
user -> a -> App Bool
isConvLeaveNotifWithLeaver Value
bob)
            LHApprovedOrPending
LHPending -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
alice Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
bob Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"
            LHApprovedOrPending
LHPending -> HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
        GroupConvAdmin
PeerIsAdmin -> do
          case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> [WebSocket] -> (WebSocket -> App Value) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WebSocket
aws, WebSocket
bws] do HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (Value -> Value -> App Bool
forall user a.
(HasCallStack, MakesValue user, MakesValue a) =>
user -> a -> App Bool
isConvLeaveNotifWithLeaver Value
alice)
            LHApprovedOrPending
LHPending -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
bob Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
alice Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"
            LHApprovedOrPending
LHPending -> HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
        GroupConvAdmin
BothAreAdmins -> do
          case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> [WebSocket] -> (WebSocket -> App Value) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WebSocket
aws, WebSocket
bws] do HasCallStack => (Value -> App Bool) -> WebSocket -> App Value
(Value -> App Bool) -> WebSocket -> App Value
awaitMatch (Value -> Value -> App Bool
forall user a.
(HasCallStack, MakesValue user, MakesValue a) =>
user -> a -> App Bool
isConvLeaveNotifWithLeaver Value
bob)
            LHApprovedOrPending
LHPending -> () -> App ()
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
alice Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
          Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getConversation Value
bob Value
qConvId App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= case LHApprovedOrPending
approvedOrPending of
            LHApprovedOrPending
LHApproved -> HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"
            LHApprovedOrPending
LHPending -> HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

testLHHappyFlow :: (HasCallStack) => Consent -> LhApiVersion -> App ()
testLHHappyFlow :: HasCallStack => Consent -> LhApiVersion -> App ()
testLHHappyFlow Consent
consent LhApiVersion
v = Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
consent ((String -> App ()) -> App ()) -> (String -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \String
dom -> do
  (alice, tid, [bob]) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
dom Int
2
  for_ [alice, bob] getSelfConversation

  let statusShouldBe :: (HasCallStack) => String -> App ()
      statusShouldBe String
status =
        String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
          Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
status

  whitelistOrEnableLHForTeam consent dom tid alice
  lpk <- getLastPrekey
  pks <- replicateM 3 getPrekey

  let ourLHMockApp = LhApiVersion
-> CreateMock App
-> Chan (Request, ByteString)
-> LiftedApplication
lhMockAppWithPrekeys LhApiVersion
v MkCreateMock {nextLastPrey :: App Value
nextLastPrey = Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
lpk, somePrekeys :: App [Value]
somePrekeys = [Value] -> App [Value]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
pks}
  withMockServer def ourLHMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe (String -> App ()) -> String -> App ()
forall a b. (a -> b) -> a -> b
$ case Consent
consent of
      Consent
Implicit -> String
"disabled"
      Consent
Explicit -> String
"no_consent"

    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
consentToLegalHold String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus case Consent
consent of
      Consent
Implicit -> Int
204
      Consent
Explicit -> Int
201
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"disabled"

    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"disabled"

    -- members cannot request LH devices
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
bob Value
alice App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"operation-denied"
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
bob Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"operation-denied"

    -- owners can; bob should now have a pending request
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    HasCallStack => String -> App ()
String -> App ()
statusShouldBe String
"pending"

    -- owner cannot approve on behalf on user under legalhold
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
approveLegalHoldDevice' String
tid Value
alice Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"access-denied"

    -- user can approve the request, however
    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200

    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"
      _ <-
        Response
resp.json
          App Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
`lookupField` String
"client.id"
          App (Maybe Value) -> (Maybe Value -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Value -> App Value
forall a. HasCallStack => String -> Maybe a -> App a
assertJust String
"client id is present"
      resp.json %. "last_prekey" `shouldMatch` lpk

    -- user cannot delete their own LH device
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
bob Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"operation-denied"
    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

    -- admin can delete LH device
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
alice Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"

testLHGetStatus :: LhApiVersion -> App ()
testLHGetStatus :: LhApiVersion -> App ()
testLHGetStatus LhApiVersion
v = do
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2

  emil <- randomUser OwnDomain def

  for_ [alice, bob, charlie, debora, emil] getSelfConversation

  let check :: (HasCallStack) => (MakesValue getter, MakesValue target) => getter -> target -> String -> App ()
      check getter
getter target
target String
status = do
        profile <- getter -> target -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getUser getter
getter target
target App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
        pStatus <- profile %. "legalhold_status" & asString
        status `shouldMatch` pStatus

  for_ [alice, bob, charlie, debora, emil] \Value
u -> do
    Value -> Value -> String -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
check Value
u Value
bob String
"no_consent"
    Value -> Value -> String -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
check Value
u Value
emil String
"no_consent"
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    [Value] -> (Value -> App ()) -> App ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Value
alice, Value
bob, Value
charlie, Value
debora, Value
emil] \Value
u -> do
      Value -> Value -> String -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
check Value
u Value
bob String
"disabled"
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    Value -> Value -> String -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
check Value
debora Value
bob String
"pending"
    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    Value -> Value -> String -> App ()
forall alice bob.
(HasCallStack, MakesValue alice, MakesValue bob) =>
alice -> bob -> String -> App ()
check Value
debora Value
bob String
"enabled"

testLHCannotCreateGroupWithUsersInConflict :: LhApiVersion -> App ()
testLHCannotCreateGroupWithUsersInConflict :: LhApiVersion -> App ()
testLHCannotCreateGroupWithUsersInConflict LhApiVersion
v = do
  (alice, tidAlice, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2
  for_ [alice, bob, charlie, debora] getSelfConversation

  legalholdWhitelistTeam tidAlice alice >>= assertStatus 200
  connectTwoUsers bob charlie
  connectTwoUsers bob debora
  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tidAlice Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    Value -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation Value
bob CreateConv
defProteus {qualifiedUsers = [charlie, alice], newUsersRole = "wire_member", team = Just tidAlice}
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tidAlice Value
alice Value
alice App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    String -> Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tidAlice Value
alice String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    String -> Value -> Value -> App Response
forall tid user owner.
(HasCallStack, MakesValue tid, MakesValue user,
 MakesValue owner) =>
tid -> owner -> user -> App Response
legalholdUserStatus String
tidAlice Value
alice Value
alice App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

    Value -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation Value
bob CreateConv
defProteus {qualifiedUsers = [debora, alice], newUsersRole = "wire_member", team = Just tidAlice}
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
403 String
"missing-legalhold-consent"

testLHNoConsentCannotBeInvited :: (HasCallStack) => LhApiVersion -> App ()
testLHNoConsentCannotBeInvited :: HasCallStack => LhApiVersion -> App ()
testLHNoConsentCannotBeInvited LhApiVersion
v = do
  -- team that is legalhold whitelisted
  (legalholder, tidLH, userLHNotActivated : _) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [legalholder, userLHNotActivated] getSelfConversation
  legalholdWhitelistTeam tidLH legalholder >>= assertStatus 200

  -- team without legalhold
  (peer, _tidPeer, [peer2, peer3]) <- createTeam OwnDomain 3
  for_ [peer, peer2, peer3] getSelfConversation

  connectUsers [peer, userLHNotActivated]
  connectUsers [peer2, userLHNotActivated]

  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tidLH Value
legalholder ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    cid <- Value -> CreateConv -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> CreateConv -> App Response
postConversation Value
userLHNotActivated CreateConv
defProteus {qualifiedUsers = [legalholder], newUsersRole = "wire_admin", team = Just tidLH} App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201
    addMembers userLHNotActivated cid (def {users = [peer], role = Just "wire_admin"}) >>= assertSuccess

    -- activate legalhold for legalholder
    requestLegalHoldDevice tidLH legalholder legalholder >>= assertSuccess
    legalholdUserStatus tidLH legalholder legalholder `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"pending"

    addMembers userLHNotActivated cid (def {users = [peer2]}) >>= assertSuccess

    approveLegalHoldDevice tidLH (legalholder %. "qualified_id") defPassword >>= assertSuccess
    legalholdUserStatus tidLH legalholder legalholder `bindResponse` \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"enabled"

    addMembers userLHNotActivated cid (def {users = [peer3]}) >>= assertLabel 403 "not-connected"

testLHDisableBeforeApproval :: (HasCallStack) => LhApiVersion -> App ()
testLHDisableBeforeApproval :: HasCallStack => LhApiVersion -> App ()
testLHDisableBeforeApproval LhApiVersion
v = do
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertStatus 200

  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    -- alice requests a legalhold device for bob and sets his status to "pending"
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    let getBob'sStatus :: App String
getBob'sStatus = (Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getUser Value
bob Value
bob App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200) App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"legalhold_status" App Value -> (App Value -> App String) -> App String
forall a b. a -> (a -> b) -> b
& App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
    App String
getBob'sStatus App String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"pending"

    -- alice disables legalhold. the status for bob should now not be pending anymore
    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
alice Value
bob String
defPassword
      App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    App String
getBob'sStatus App String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"disabled"

-- ---------
-- WPB-10783
-- ---------
testBlockLHForMLSUsers :: (HasCallStack) => App ()
testBlockLHForMLSUsers :: HasCallStack => App ()
testBlockLHForMLSUsers = do
  -- scenario 1:
  -- if charlie is in any MLS conversation, he cannot approve to be put under legalhold
  (charlie, tid, []) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
1
  void $ getSelfConversation charlie
  [charlie1] <- traverse (createMLSClient def) [charlie]
  convId <- createNewGroup def charlie1
  void $ createAddCommit charlie1 convId [charlie] >>= sendAndConsumeCommitBundle

  legalholdWhitelistTeam tid charlie >>= assertStatus 200
  withMockServer def lhMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
charlie ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
charlie Value
charlie App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` do
      HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
409 String
"mls-legal-hold-not-allowed"

-- ---------
-- WPB-10772
-- ---------

--  | scenario 2.1:
-- charlie first is put under legalhold and after that wants to join an MLS conversation
-- claiming a keypackage of charlie to add them to a conversation should not be possible
testBlockClaimingKeyPackageForLHUsers :: (HasCallStack) => App ()
testBlockClaimingKeyPackageForLHUsers :: HasCallStack => App ()
testBlockClaimingKeyPackageForLHUsers = do
  (alice, tid, [charlie]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, charlie] getSelfConversation
  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
  _ <- uploadNewKeyPackage def charlie1
  _ <- createNewGroup def alice1
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def lhMockApp \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
charlie App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    String -> App Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid (Value
charlie Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    profile <- Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getUser Value
alice Value
charlie App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    pStatus <- profile %. "legalhold_status" & asString
    pStatus `shouldMatch` "enabled"

    claimKeyPackages def alice1 charlie
      `bindResponse` assertLabel 409 "mls-legal-hold-not-allowed"

-- | scenario 2.2:
-- charlie is put under legalhold but creates an MLS Group himself
-- since he doesn't need to claim his own keypackage to do so, this would succeed
-- we need to check upon group creation if the user is under legalhold and reject
-- the operation if they are
testBlockCreateMLSConvForLHUsers :: (HasCallStack) => LhApiVersion -> App ()
testBlockCreateMLSConvForLHUsers :: HasCallStack => LhApiVersion -> App ()
testBlockCreateMLSConvForLHUsers LhApiVersion
v = do
  (alice, tid, [charlie]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, charlie] getSelfConversation
  [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie]
  _ <- uploadNewKeyPackage def alice1
  legalholdWhitelistTeam tid alice >>= assertStatus 200
  withMockServer def (lhMockAppV v) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
_chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201
    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
charlie App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    String -> App Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid (Value
charlie Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    profile <- Value -> Value -> App Response
forall user qcnv.
(HasCallStack, MakesValue user, MakesValue qcnv) =>
user -> qcnv -> App Response
getUser Value
alice Value
charlie App Response -> (Response -> App Value) -> App Value
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200
    pStatus <- profile %. "legalhold_status" & asString
    pStatus `shouldMatch` "enabled"

    -- charlie tries to create a group and should fail when POSTing the add commit
    convId <- createNewGroup def charlie1

    void
      -- we try to add alice since adding charlie himself would trigger 2.1
      -- since he'd try to claim his own keypackages
      $ createAddCommit charlie1 convId [alice]
      >>= \MessagePackage
mp ->
        HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle MessagePackage
mp.sender (MessagePackage -> ByteString
mkBundle MessagePackage
mp)
          App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
409 String
"mls-legal-hold-not-allowed"

    -- (unsurprisingly) this same thing should also work in the one2one case

    respJson <- getMLSOne2OneConversation alice charlie >>= getJSON 200
    createGroup def alice1 =<< objConvId (respJson %. "conversation")

    void
      -- we try to add alice since adding charlie himself would trigger 2.1
      -- since he'd try to claim his own keypackages
      $ createAddCommit charlie1 convId [alice]
      >>= \MessagePackage
mp ->
        HasCallStack => ClientIdentity -> ByteString -> App Response
ClientIdentity -> ByteString -> App Response
postMLSCommitBundle MessagePackage
mp.sender (MessagePackage -> ByteString
mkBundle MessagePackage
mp)
          App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
`bindResponse` HasCallStack => Int -> String -> Response -> App ()
Int -> String -> Response -> App ()
assertLabel Int
409 String
"mls-legal-hold-not-allowed"

testLHApiV1 :: App ()
testLHApiV1 :: App ()
testLHApiV1 = do
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertSuccess

  withMockServer def (lhMockAppV V1) \(String, Int)
lhDomAndPort Chan (Request, ByteString)
chan -> do
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
_) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"GET"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"status"])

    String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
_) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"GET"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"api-version"])

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
body) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"POST"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"v1", String
"initiate"])
      let (Just (Value
value :: Value)) = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"team_id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
tid
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.id" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.domain" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain Value
bob

    String -> App Value -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice String
tid (Value
bob Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_id") String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
_) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"GET"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"api-version"])

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
body) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"POST"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"v1", String
"confirm"])
      let (Just (Value
value :: Value)) = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"team_id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
tid
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.id" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.domain" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain Value
bob
      (Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Value -> Bool) -> App (Maybe Value) -> App Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value
value Value -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
`lookupField` String
"client_id") App Bool -> Bool -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Bool
True

    String -> Value -> Value -> String -> App Response
forall tid uid forUid.
(HasCallStack, MakesValue tid, MakesValue uid,
 MakesValue forUid) =>
tid -> uid -> forUid -> String -> App Response
disableLegalHold String
tid Value
alice Value
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
_) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"GET"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"api-version"])

    Chan (Request, ByteString)
-> ((Request, ByteString) -> App (Maybe ())) -> App ()
forall t a. HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a
checkChan Chan (Request, ByteString)
chan \(Request
req, ByteString
body) -> MaybeT App () -> App (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT App () -> App (Maybe ()))
-> (App () -> MaybeT App ()) -> App () -> App (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App () -> MaybeT App ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (App () -> App (Maybe ())) -> App () -> App (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
      ByteString -> String
BS8.unpack Request
req.requestMethod String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"POST"
      Request
req.pathInfo [Text] -> [Text] -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"legalhold", String
"v1", String
"remove"])
      let (Just (Value
value :: Value)) = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"team_id" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
tid
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.id" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId Value
bob
      Value
value Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"qualified_user_id.domain" App Value -> App String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain Value
bob

testNoCommonVersion :: App ()
testNoCommonVersion :: App ()
testNoCommonVersion = do
  (alice, tid, [bob]) <- Domain -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam Domain
OwnDomain Int
2
  for_ [alice, bob] getSelfConversation

  legalholdWhitelistTeam tid alice >>= assertSuccess

  withMockServer def lhMockNoCommonVersion \(String, Int)
lhDomAndPort Chan ()
_ -> do
    String -> Value -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdWhitelistTeam String
tid Value
alice App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200
    String -> Value -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings String
tid Value
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhDomAndPort) App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess

    App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Value -> Value -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice String
tid Value
alice Value
bob) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
      Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
500
      Response
resp.json App Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
"server-error"

-- | LH can be configured in a way that does not require users to give preliminary consent to
-- LH when being added to a team.  The user still has to approve the LH device before the
-- recording starts.  This is called "implicit consent", was introduced to accomodate specific
-- work flows, and there is some hope that it'll be removed in the future.
--
-- Explicit consent requires users to consent on entering the team, and then approve the
-- actual being put under recording again if it happens.
--
-- This flag allows to make tests run through both configurations with minimal adjustment.
data Consent = Implicit | Explicit
  deriving (Consent -> Consent -> Bool
(Consent -> Consent -> Bool)
-> (Consent -> Consent -> Bool) -> Eq Consent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Consent -> Consent -> Bool
== :: Consent -> Consent -> Bool
$c/= :: Consent -> Consent -> Bool
/= :: Consent -> Consent -> Bool
Eq, Int -> Consent -> String -> String
[Consent] -> String -> String
Consent -> String
(Int -> Consent -> String -> String)
-> (Consent -> String)
-> ([Consent] -> String -> String)
-> Show Consent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Consent -> String -> String
showsPrec :: Int -> Consent -> String -> String
$cshow :: Consent -> String
show :: Consent -> String
$cshowList :: [Consent] -> String -> String
showList :: [Consent] -> String -> String
Show, (forall x. Consent -> Rep Consent x)
-> (forall x. Rep Consent x -> Consent) -> Generic Consent
forall x. Rep Consent x -> Consent
forall x. Consent -> Rep Consent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Consent -> Rep Consent x
from :: forall x. Consent -> Rep Consent x
$cto :: forall x. Rep Consent x -> Consent
to :: forall x. Rep Consent x -> Consent
Generic)

-- | Ensure that the LH config is as expected: Either by expecting it from the
-- current server's config. Or, by creating a new one.
ensureLHFeatureConfigForServer :: Consent -> (String {- domain -} -> App ()) -> App ()
ensureLHFeatureConfigForServer :: Consent -> (String -> App ()) -> App ()
ensureLHFeatureConfigForServer Consent
Implicit String -> App ()
app = do
  -- This should be set in the server's config file. Thus, we only assert here
  -- (to guard against accidential change.)
  cfg <- Service -> App Value
readServiceConfig Service
Galley
  (cfg %. "settings.featureFlags.legalhold") `shouldMatch` "whitelist-teams-and-implicit-consent"
  app =<< asString OwnDomain
ensureLHFeatureConfigForServer Consent
Explicit String -> App ()
app =
  ServiceOverrides -> (HasCallStack => String -> App ()) -> App ()
forall a.
HasCallStack =>
ServiceOverrides -> (HasCallStack => String -> App a) -> App a
withModifiedBackend (ServiceOverrides
forall a. Default a => a
def {galleyCfg = upd}) HasCallStack => String -> App ()
String -> App ()
app
  where
    upd :: Value -> App Value
upd = String -> String -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"settings.featureFlags.legalhold" String
"disabled-by-default"

whitelistOrEnableLHForTeam :: (HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) => Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam :: forall tid user dom.
(HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) =>
Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam Consent
consent dom
dom tid
tid user
user = do
  case Consent
consent of
    Consent
Implicit -> do
      tid -> user -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdWhitelistTeam tid
tid user
user App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
      tid -> user -> App Response
forall uid tid.
(HasCallStack, MakesValue uid, MakesValue tid) =>
tid -> uid -> App Response
legalholdIsTeamInWhitelist tid
tid user
user App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess
    Consent
Explicit -> do
      -- legalhold has implicit lock status "unlocked", so it just needs to be enabled:
      let payload :: Value
payload = [Pair] -> Value
object [String
"status" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"enabled"]
      dom -> tid -> String -> Value -> App Response
forall domain team featureName payload.
(HasCallStack, MakesValue domain, MakesValue team,
 MakesValue featureName, MakesValue payload) =>
domain -> team -> featureName -> payload -> App Response
API.GalleyInternal.setTeamFeatureConfig dom
dom tid
tid String
"legalhold" Value
payload App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Response -> App ()
Response -> App ()
assertSuccess

-- | setup a legalhold device for @uid@, authorised by @owner@
--   at the specified port
setUpLHDevice ::
  (HasCallStack, MakesValue dom, MakesValue tid, MakesValue owner, MakesValue uid) =>
  Consent ->
  dom ->
  tid ->
  owner ->
  uid ->
  -- | the host and port the LH service is running on
  (String, Int) ->
  App ()
setUpLHDevice :: forall dom tid owner uid.
(HasCallStack, MakesValue dom, MakesValue tid, MakesValue owner,
 MakesValue uid) =>
Consent -> dom -> tid -> owner -> uid -> (String, Int) -> App ()
setUpLHDevice Consent
consent dom
dom tid
tid owner
alice uid
bob (String, Int)
lhPort = do
  Consent -> dom -> tid -> owner -> App ()
forall tid user dom.
(HasCallStack, MakesValue tid, MakesValue user, MakesValue dom) =>
Consent -> dom -> tid -> user -> App ()
whitelistOrEnableLHForTeam Consent
consent dom
dom tid
tid owner
alice

  -- the status messages for these have already been tested
  tid -> owner -> Value -> App Response
forall ownerid tid newService.
(HasCallStack, MakesValue ownerid, MakesValue tid,
 MakesValue newService) =>
tid -> ownerid -> newService -> App Response
postLegalHoldSettings tid
tid owner
alice ((String, Int) -> Value
mkLegalHoldSettings (String, Int)
lhPort)
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

  let expected :: Int
expected = case Consent
consent of
        Consent
Implicit -> Int
204
        Consent
Explicit -> Int
201
   in tid -> uid -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
consentToLegalHold tid
tid uid
bob String
defPassword App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
expected
  tid -> owner -> uid -> App Response
forall tid ownerid uid.
(HasCallStack, MakesValue tid, MakesValue ownerid,
 MakesValue uid) =>
tid -> ownerid -> uid -> App Response
requestLegalHoldDevice tid
tid owner
alice uid
bob
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
201

  tid -> uid -> String -> App Response
forall tid uid.
(HasCallStack, MakesValue tid, MakesValue uid) =>
tid -> uid -> String -> App Response
approveLegalHoldDevice tid
tid uid
bob String
defPassword
    App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200