module Test.Migration.ConversationCodes where

import API.Galley
import Control.Applicative
import Control.Concurrent.Timeout
import Control.Monad.Codensity
import Control.Monad.Reader
import SetupHelpers
import Test.Migration.Util (waitForMigration)
import Testlib.Prelude
import Testlib.ResourcePool

testConversationCodesMigration :: (HasCallStack) => TaggedBool "has-password" -> TaggedBool "with-zHost" -> App ()
testConversationCodesMigration :: HasCallStack =>
TaggedBool "has-password" -> TaggedBool "with-zHost" -> App ()
testConversationCodesMigration (TaggedBool Bool
hasPassword) (TaggedBool Bool
withZhost) = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
  let pw = if Bool
hasPassword then String -> Maybe String
forall a. a -> Maybe a
Just String
"funky password" else Maybe String
forall a. Maybe a
Nothing
      mbZHost = if Bool
withZhost then String -> Maybe String
forall a. a -> Maybe a
Just String
"zhost.example.com" else Maybe String
forall a. Maybe a
Nothing

  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
backend] -> do
    let domain :: String
domain = BackendResource
backend.berDomain

    (admin, code1, codeA, convs, members) <- Codensity App String -> forall b. (String -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
backend (String -> Bool -> ServiceOverrides
conf String
"cassandra" Bool
False)) ((String
  -> App
       (Value, (String, String), (String, String), [Value], [Value]))
 -> App
      (Value, (String, String), (String, String), [Value], [Value]))
-> (String
    -> App
         (Value, (String, String), (String, String), [Value], [Value]))
-> App
     (Value, (String, String), (String, String), [Value], [Value])
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      (admin, _, members) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
6
      convs1@(conv1 : _) <- replicateM 5 $ postConversation admin (allowGuests defProteus) >>= getJSON 201
      convs2@(convA : _) <- replicateM 4 $ postConversation admin (allowGuests defProteus) >>= getJSON 201
      code1 <- genCode admin conv1 pw
      codeA <- genCode admin convA pw
      pure (admin, code1, codeA, convs1 <> convs2, members)

    [conv1, conv2, conv3, conv4, conv5, convA, convB, convC, convD] <- pure convs
    m1 : m2 : m3 : m4 : _ <- pure members

    (code2, codeB) <- runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" False)) $ \String
_ -> do
      -- code generation works
      code2 <- Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv2 Maybe String
pw
      codeB <- genCode admin convB pw
      -- joining works
      checkJoinAndGet admin m1 conv1 code1 mbZHost
      checkJoinAndGet admin m1 conv2 code2 mbZHost
      -- deletion works
      checkDelete admin m1 convA codeA mbZHost
      pure (code2, codeB)

    (code3, codeC) <- runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" True)) $ \String
_ -> do
      -- code generation works
      code3 <- Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv3 Maybe String
pw
      codeC <- genCode admin convC pw
      -- joining works
      checkJoinAndGet admin m2 conv1 code1 mbZHost
      checkJoinAndGet admin m2 conv2 code2 mbZHost
      checkJoinAndGet admin m2 conv3 code3 mbZHost
      -- deletion works
      checkNoCode admin m1 convA codeA mbZHost
      checkDelete admin m1 convB codeB mbZHost
      waitForMigration domain counterName
      pure (code3, codeC)

    (code4, codeD) <- runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" False)) $ \String
_ -> do
      -- code generation works
      code4 <- Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv4 Maybe String
pw
      codeD <- genCode admin convD pw
      -- joining works
      checkJoinAndGet admin m3 conv1 code1 mbZHost
      checkJoinAndGet admin m3 conv2 code2 mbZHost
      checkJoinAndGet admin m3 conv3 code3 mbZHost
      checkJoinAndGet admin m3 conv4 code4 mbZHost
      -- deletion works
      checkNoCode admin m1 convA codeA mbZHost
      checkNoCode admin m1 convB codeB mbZHost
      checkDelete admin m1 convC codeC mbZHost
      pure (code4, codeD)

    runCodensity (startDynamicBackend backend (conf "postgresql" False)) $ \String
_ -> do
      -- code generation works
      code5 <- Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv5 Maybe String
pw
      -- joining works
      checkJoinAndGet admin m4 conv1 code1 mbZHost
      checkJoinAndGet admin m4 conv2 code2 mbZHost
      checkJoinAndGet admin m4 conv3 code3 mbZHost
      checkJoinAndGet admin m4 conv4 code4 mbZHost
      checkJoinAndGet admin m4 conv5 code5 mbZHost
      -- deletion works
      checkNoCode admin m1 convA codeA mbZHost
      checkNoCode admin m1 convB codeB mbZHost
      checkNoCode admin m1 convC codeC mbZHost
      checkDelete admin m1 convD codeD mbZHost
      checkDelete admin m1 conv5 code5 mbZHost
  where
    checkJoinAndGet :: user -> user -> Value -> (String, String) -> Maybe String -> App ()
checkJoinAndGet user
admin user
user Value
conv (String, String)
code Maybe String
mbZHost = do
      user -> Value -> (String, String) -> App ()
forall user.
(HasCallStack, MakesValue user) =>
user -> Value -> (String, String) -> App ()
joinWithCode user
user Value
conv (String, String)
code
      user -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
getCode user
admin Value
conv Maybe String
mbZHost App (String, String) -> (String, String) -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String, String)
code
    checkDelete :: user -> user -> conv -> (String, String) -> Maybe String -> App ()
checkDelete user
admin user
user conv
conv (String
k, String
v) Maybe String
mbZHost = do
      HasCallStack => Response -> App ()
Response -> App ()
assertSuccess (Response -> App ()) -> App Response -> App ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< user -> conv -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> App Response
deleteConversationCode user
admin conv
conv
      user -> user -> conv -> (String, String) -> Maybe String -> App ()
forall {user} {conv} {user}.
(MakesValue user, MakesValue conv, MakesValue user) =>
user -> user -> conv -> (String, String) -> Maybe String -> App ()
checkNoCode user
admin user
user conv
conv (String
k, String
v) Maybe String
mbZHost
    checkNoCode :: user -> user -> conv -> (String, String) -> Maybe String -> App ()
checkNoCode user
admin user
user conv
conv (String
k, String
v) Maybe String
mbZHost = do
      HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
404 (Response -> App ()) -> App Response -> App ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< user -> conv -> Maybe String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App Response
getConversationCode user
admin conv
conv Maybe String
mbZHost
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
getJoinCodeConv user
user String
k String
v) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
        Response
res.json Maybe 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-conversation-code"

testConversationCodesMigrationExpiration :: (HasCallStack) => App ()
testConversationCodesMigrationExpiration :: HasCallStack => App ()
testConversationCodesMigrationExpiration = do
  resourcePool <- (Env -> ResourcePool BackendResource)
-> App (ResourcePool BackendResource)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.resourcePool)
  let pw = Maybe a
forall a. Maybe a
Nothing

  runCodensity (acquireResources 1 resourcePool) $ \[BackendResource
backend] -> do
    let domain :: String
domain = BackendResource
backend.berDomain

    (admin, code1, conv, mem) <- Codensity App String -> forall b. (String -> App b) -> App b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
backend (String -> Bool -> Int -> ServiceOverrides
confWithExpiry String
"cassandra" Bool
False Int
2)) ((String -> App (Value, (String, String), Value, Value))
 -> App (Value, (String, String), Value, Value))
-> (String -> App (Value, (String, String), Value, Value))
-> App (Value, (String, String), Value, Value)
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
      (admin, _, mem : _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
2
      conv <- postConversation admin (allowGuests defProteus) >>= getJSON 201
      code1 <- genCode admin conv pw
      pure (admin, code1, conv, mem)

    code2 <- runCodensity (startDynamicBackend backend (confWithExpiry "migration-to-postgresql" False 2)) $ \String
_ -> do
      Value -> Value -> Maybe String -> App ()
forall user conv.
(MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App ()
waitForCodeToExpire Value
admin Value
conv Maybe String
forall a. Maybe a
pw
      Value -> (String, String) -> App ()
forall {user}.
MakesValue user =>
user -> (String, String) -> App ()
checkCantJoin Value
mem (String, String)
code1
      Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv Maybe String
forall a. Maybe a
pw

    code3 <- runCodensity (startDynamicBackend backend (confWithExpiry "migration-to-postgresql" True 2)) $ \String
_ -> do
      Value -> Value -> Maybe String -> App ()
forall user conv.
(MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App ()
waitForCodeToExpire Value
admin Value
conv Maybe String
forall a. Maybe a
pw
      Value -> (String, String) -> App ()
forall {user}.
MakesValue user =>
user -> (String, String) -> App ()
checkCantJoin Value
mem (String, String)
code2
      Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv Maybe String
forall a. Maybe a
pw

    code4 <- runCodensity (startDynamicBackend backend (confWithExpiry "migration-to-postgresql" False 2)) $ \String
_ -> do
      Value -> Value -> Maybe String -> App ()
forall user conv.
(MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App ()
waitForCodeToExpire Value
admin Value
conv Maybe String
forall a. Maybe a
pw
      Value -> (String, String) -> App ()
forall {user}.
MakesValue user =>
user -> (String, String) -> App ()
checkCantJoin Value
mem (String, String)
code3
      Value -> Value -> Maybe String -> App (String, String)
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode Value
admin Value
conv Maybe String
forall a. Maybe a
pw
    runCodensity (startDynamicBackend backend (confWithExpiry "postgresql" False 2)) $ \String
_ -> do
      Value -> Value -> Maybe String -> App ()
forall user conv.
(MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App ()
waitForCodeToExpire Value
admin Value
conv Maybe String
forall a. Maybe a
pw
      Value -> (String, String) -> App ()
forall {user}.
MakesValue user =>
user -> (String, String) -> App ()
checkCantJoin Value
mem (String, String)
code4
  where
    checkCantJoin :: user -> (String, String) -> App ()
checkCantJoin user
user (String
k, String
v) = do
      App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
getJoinCodeConv user
user String
k String
v) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
404
        Response
res.json Maybe 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-conversation-code"

-- HELPER

genCode :: (HasCallStack, MakesValue user, MakesValue conv) => user -> conv -> Maybe String -> App (String, String)
genCode :: forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
genCode user
user conv
conv Maybe String
pw =
  App Response
-> (Response -> App (String, String)) -> App (String, String)
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> conv -> Maybe String -> Maybe String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> Maybe String -> App Response
postConversationCode user
user conv
conv Maybe String
pw Maybe String
forall a. Maybe a
Nothing) ((Response -> App (String, String)) -> App (String, String))
-> (Response -> App (String, String)) -> App (String, String)
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    payload <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
201 Response
res
    k <- payload %. "data.key" & asString
    v <- payload %. "data.code" & asString
    pure (k, v)

getCode :: (HasCallStack, MakesValue user, MakesValue conv) => user -> conv -> Maybe String -> App (String, String)
getCode :: forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App (String, String)
getCode user
user conv
conv Maybe String
mbZHost =
  App Response
-> (Response -> App (String, String)) -> App (String, String)
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> conv -> Maybe String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App Response
getConversationCode user
user conv
conv Maybe String
mbZHost) ((Response -> App (String, String)) -> App (String, String))
-> (Response -> App (String, String)) -> App (String, String)
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    payload <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
200 Response
res
    k <- payload %. "key" & asString
    v <- payload %. "code" & asString
    pure (k, v)

waitForCodeToExpire :: (MakesValue user, MakesValue conv) => user -> conv -> Maybe String -> App ()
waitForCodeToExpire :: forall user conv.
(MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App ()
waitForCodeToExpire user
user conv
conv Maybe String
mbZHost = do
  res <- user -> conv -> Maybe String -> App Response
forall user conv.
(HasCallStack, MakesValue user, MakesValue conv) =>
user -> conv -> Maybe String -> App Response
getConversationCode user
user conv
conv Maybe String
mbZHost
  if res.status == 404
    then pure ()
    else do
      liftIO $ threadDelay 100_000
      waitForCodeToExpire user conv mbZHost

joinWithCode :: (HasCallStack, MakesValue user) => user -> Value -> (String, String) -> App ()
joinWithCode :: forall user.
(HasCallStack, MakesValue user) =>
user -> Value -> (String, String) -> App ()
joinWithCode user
user Value
conv (String
k, String
v) =
  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (user -> String -> String -> App Response
forall user.
(HasCallStack, MakesValue user) =>
user -> String -> String -> App Response
getJoinCodeConv user
user String
k String
v) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    Response
res.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
res.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> App String -> 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
conv 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
objId)

conf :: String -> Bool -> ServiceOverrides
conf :: String -> Bool -> ServiceOverrides
conf String
db Bool
runMigration = String -> Bool -> Int -> ServiceOverrides
confWithExpiry String
db Bool
runMigration Int
604800

confWithExpiry :: String -> Bool -> Int -> ServiceOverrides
confWithExpiry :: String -> Bool -> Int -> ServiceOverrides
confWithExpiry String
db Bool
runMigration Int
expiry =
  ServiceOverrides
forall a. Default a => a
def
    { galleyCfg =
        setField "postgresMigration.conversationCodes" db
          >=> setField "settings.guestLinkTTLSeconds" expiry,
      backgroundWorkerCfg = setField "migrateConversationCodes" runMigration
    }

counterName :: String
counterName :: String
counterName = String
"^wire_conv_codes_migration_finished"