{-# LANGUAGE OverloadedStrings #-}

module Testlib.Env where

import Control.Monad.Codensity
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Default
import Data.Function ((&))
import Data.Functor
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Traversable (for)
import qualified Data.Yaml as Yaml
import qualified Database.CQL.IO as Cassandra
import qualified Network.HTTP.Client as HTTP
import qualified OpenSSL.Session as OpenSSL
import System.Directory
import System.Environment (lookupEnv)
import System.Exit
import System.FilePath
import System.IO
import System.IO.Temp
import Testlib.Prekeys
import Testlib.ResourcePool
import Testlib.Types
import Text.Read (readMaybe)
import Prelude

serviceHostPort :: ServiceMap -> Service -> HostPort
serviceHostPort :: ServiceMap -> Service -> HostPort
serviceHostPort ServiceMap
m Service
Brig = ServiceMap
m.brig
serviceHostPort ServiceMap
m Service
Galley = ServiceMap
m.galley
serviceHostPort ServiceMap
m Service
Cannon = ServiceMap
m.cannon
serviceHostPort ServiceMap
m Service
Gundeck = ServiceMap
m.gundeck
serviceHostPort ServiceMap
m Service
Cargohold = ServiceMap
m.cargohold
serviceHostPort ServiceMap
m Service
Nginz = ServiceMap
m.nginz
serviceHostPort ServiceMap
m Service
Spar = ServiceMap
m.spar
serviceHostPort ServiceMap
m Service
BackgroundWorker = ServiceMap
m.backgroundWorker
serviceHostPort ServiceMap
m Service
Stern = ServiceMap
m.stern
serviceHostPort ServiceMap
m Service
FederatorInternal = ServiceMap
m.federatorInternal

mkGlobalEnv :: FilePath -> Codensity IO GlobalEnv
mkGlobalEnv :: String -> Codensity IO GlobalEnv
mkGlobalEnv String
cfgFile = do
  Either ParseException IntegrationConfig
eith <- IO (Either ParseException IntegrationConfig)
-> Codensity IO (Either ParseException IntegrationConfig)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ParseException IntegrationConfig)
 -> Codensity IO (Either ParseException IntegrationConfig))
-> IO (Either ParseException IntegrationConfig)
-> Codensity IO (Either ParseException IntegrationConfig)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either ParseException IntegrationConfig)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither String
cfgFile
  IntegrationConfig
intConfig <- IO IntegrationConfig -> Codensity IO IntegrationConfig
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IntegrationConfig -> Codensity IO IntegrationConfig)
-> IO IntegrationConfig -> Codensity IO IntegrationConfig
forall a b. (a -> b) -> a -> b
$ case Either ParseException IntegrationConfig
eith of
    Left ParseException
err -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cfgFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
Yaml.prettyPrintParseException ParseException
err
      IO IntegrationConfig
forall a. IO a
exitFailure
    Right (IntegrationConfig
intConfig :: IntegrationConfig) -> IntegrationConfig -> IO IntegrationConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntegrationConfig
intConfig

  let devEnvProjectRoot :: Maybe String
devEnvProjectRoot = case String -> [String]
splitPath (String -> String
takeDirectory String
cfgFile) of
        [] -> Maybe String
forall a. Maybe a
Nothing
        [String]
ps ->
          if [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ps String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"services"
            then String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
joinPath ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
ps))
            else Maybe String
forall a. Maybe a
Nothing
      IO (Maybe String)
getCassCertFilePath :: IO (Maybe FilePath) =
        IO (Maybe String)
-> (String -> IO (Maybe String))
-> Maybe String
-> IO (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing)
          ( \String
certFilePath ->
              if String -> Bool
isAbsolute String
certFilePath
                then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
certFilePath
                else Maybe String -> (String -> IO String) -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe String
devEnvProjectRoot ((String -> IO String) -> IO (Maybe String))
-> (String -> IO String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \String
projectRoot -> String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
combine String
projectRoot String
certFilePath
          )
          IntegrationConfig
intConfig.cassandra.cassTlsCa

  Manager
manager <- IO Manager -> Codensity IO Manager
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> Codensity IO Manager)
-> IO Manager -> Codensity IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings

  Maybe String
mbCassCertFilePath <- IO (Maybe String) -> Codensity IO (Maybe String)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Codensity IO (Maybe String))
-> IO (Maybe String) -> Codensity IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO (Maybe String)
getCassCertFilePath
  Maybe SSLContext
mbSSLContext <- IO (Maybe SSLContext) -> Codensity IO (Maybe SSLContext)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SSLContext) -> Codensity IO (Maybe SSLContext))
-> IO (Maybe SSLContext) -> Codensity IO (Maybe SSLContext)
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe SSLContext)
createSSLContext Maybe String
mbCassCertFilePath
  let basicCassSettings :: Settings
basicCassSettings =
        Settings
Cassandra.defSettings
          Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& String -> [String] -> Settings -> Settings
Cassandra.setContacts IntegrationConfig
intConfig.cassandra.cassHost []
          Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& PortNumber -> Settings -> Settings
Cassandra.setPortNumber (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral IntegrationConfig
intConfig.cassandra.cassPort)
      cassSettings :: Settings
cassSettings = Settings
-> (SSLContext -> Settings) -> Maybe SSLContext -> Settings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Settings
basicCassSettings (\SSLContext
sslCtx -> SSLContext -> Settings -> Settings
Cassandra.setSSLContext SSLContext
sslCtx Settings
basicCassSettings) Maybe SSLContext
mbSSLContext
  ClientState
cassClient <- Settings -> Codensity IO ClientState
forall (m :: * -> *). MonadIO m => Settings -> m ClientState
Cassandra.init Settings
cassSettings
  let resources :: [BackendResource]
resources = [DynamicBackendConfig] -> [BackendResource]
backendResources (Map String DynamicBackendConfig -> [DynamicBackendConfig]
forall k a. Map k a -> [a]
Map.elems IntegrationConfig
intConfig.dynamicBackends)
  ResourcePool BackendResource
resourcePool <-
    IO (ResourcePool BackendResource)
-> Codensity IO (ResourcePool BackendResource)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ResourcePool BackendResource)
 -> Codensity IO (ResourcePool BackendResource))
-> IO (ResourcePool BackendResource)
-> Codensity IO (ResourcePool BackendResource)
forall a b. (a -> b) -> a -> b
$
      [BackendResource]
-> RabbitMQConfig
-> ClientState
-> IO (ResourcePool BackendResource)
createBackendResourcePool
        [BackendResource]
resources
        IntegrationConfig
intConfig.rabbitmq
        ClientState
cassClient
  let sm :: Map String ServiceMap
sm =
        [(String, ServiceMap)] -> Map String ServiceMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, ServiceMap)] -> Map String ServiceMap)
-> [(String, ServiceMap)] -> Map String ServiceMap
forall a b. (a -> b) -> a -> b
$
          [ (IntegrationConfig
intConfig.backendOne.originDomain, IntegrationConfig
intConfig.backendOne.beServiceMap),
            (IntegrationConfig
intConfig.backendTwo.originDomain, IntegrationConfig
intConfig.backendTwo.beServiceMap),
            (IntegrationConfig
intConfig.federationV0.originDomain, IntegrationConfig
intConfig.federationV0.beServiceMap),
            (IntegrationConfig
intConfig.federationV1.originDomain, IntegrationConfig
intConfig.federationV1.beServiceMap)
          ]
            [(String, ServiceMap)]
-> [(String, ServiceMap)] -> [(String, ServiceMap)]
forall a. Semigroup a => a -> a -> a
<> [(BackendResource -> String
berDomain BackendResource
resource, BackendResource -> ServiceMap
resourceServiceMap BackendResource
resource) | BackendResource
resource <- [BackendResource]
resources]
  String
tempDir <- (forall b. (String -> IO b) -> IO b) -> Codensity IO String
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (String -> IO b) -> IO b) -> Codensity IO String)
-> (forall b. (String -> IO b) -> IO b) -> Codensity IO String
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO b) -> IO b
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"test"
  Int
timeOutSeconds <-
    IO Int -> Codensity IO Int
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Codensity IO Int) -> IO Int -> Codensity IO Int
forall a b. (a -> b) -> a -> b
$
      Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
10 (Maybe Int -> Int)
-> (Maybe String -> Maybe Int) -> Maybe String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Read a => String -> Maybe a
readMaybe @Int =<<) (Maybe String -> Int) -> IO (Maybe String) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TEST_TIMEOUT_SECONDS"
  GlobalEnv -> Codensity IO GlobalEnv
forall a. a -> Codensity IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    GlobalEnv
      { $sel:gServiceMap:GlobalEnv :: Map String ServiceMap
gServiceMap = Map String ServiceMap
sm,
        $sel:gDomain1:GlobalEnv :: String
gDomain1 = IntegrationConfig
intConfig.backendOne.originDomain,
        $sel:gDomain2:GlobalEnv :: String
gDomain2 = IntegrationConfig
intConfig.backendTwo.originDomain,
        $sel:gIntegrationTestHostName:GlobalEnv :: String
gIntegrationTestHostName = IntegrationConfig
intConfig.integrationTestHostName,
        $sel:gFederationV0Domain:GlobalEnv :: String
gFederationV0Domain = IntegrationConfig
intConfig.federationV0.originDomain,
        $sel:gFederationV1Domain:GlobalEnv :: String
gFederationV1Domain = IntegrationConfig
intConfig.federationV1.originDomain,
        $sel:gDynamicDomains:GlobalEnv :: [String]
gDynamicDomains = (.domain) (DynamicBackendConfig -> String)
-> [DynamicBackendConfig] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String DynamicBackendConfig -> [DynamicBackendConfig]
forall k a. Map k a -> [a]
Map.elems IntegrationConfig
intConfig.dynamicBackends,
        $sel:gDefaultAPIVersion:GlobalEnv :: Int
gDefaultAPIVersion = Int
7,
        $sel:gManager:GlobalEnv :: Manager
gManager = Manager
manager,
        $sel:gServicesCwdBase:GlobalEnv :: Maybe String
gServicesCwdBase = Maybe String
devEnvProjectRoot Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
</> String
"services"),
        $sel:gBackendResourcePool:GlobalEnv :: ResourcePool BackendResource
gBackendResourcePool = ResourcePool BackendResource
resourcePool,
        $sel:gRabbitMQConfig:GlobalEnv :: RabbitMQConfig
gRabbitMQConfig = IntegrationConfig
intConfig.rabbitmq,
        $sel:gTempDir:GlobalEnv :: String
gTempDir = String
tempDir,
        $sel:gTimeOutSeconds:GlobalEnv :: Int
gTimeOutSeconds = Int
timeOutSeconds
      }
  where
    createSSLContext :: Maybe FilePath -> IO (Maybe OpenSSL.SSLContext)
    createSSLContext :: Maybe String -> IO (Maybe SSLContext)
createSSLContext (Just String
certFilePath) = do
      String -> IO ()
forall a. Show a => a -> IO ()
print (String
"TLS: Connecting to Cassandra with TLS. Provided CA path:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
certFilePath)
      SSLContext
sslContext <- IO SSLContext
OpenSSL.context
      SSLContext -> String -> IO ()
OpenSSL.contextSetCAFile SSLContext
sslContext String
certFilePath
      SSLContext -> VerificationMode -> IO ()
OpenSSL.contextSetVerificationMode
        SSLContext
sslContext
        OpenSSL.VerifyPeer
          { vpFailIfNoPeerCert :: Bool
vpFailIfNoPeerCert = Bool
True,
            vpClientOnce :: Bool
vpClientOnce = Bool
True,
            vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool)
vpCallback = Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing
          }
      Maybe SSLContext -> IO (Maybe SSLContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SSLContext -> IO (Maybe SSLContext))
-> Maybe SSLContext -> IO (Maybe SSLContext)
forall a b. (a -> b) -> a -> b
$ SSLContext -> Maybe SSLContext
forall a. a -> Maybe a
Just SSLContext
sslContext
    createSSLContext Maybe String
Nothing = Maybe SSLContext -> IO (Maybe SSLContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SSLContext
forall a. Maybe a
Nothing

mkEnv :: GlobalEnv -> Codensity IO Env
mkEnv :: GlobalEnv -> Codensity IO Env
mkEnv GlobalEnv
ge = do
  IORef MLSState
mls <- IO (IORef MLSState) -> Codensity IO (IORef MLSState)
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef MLSState) -> Codensity IO (IORef MLSState))
-> (MLSState -> IO (IORef MLSState))
-> MLSState
-> Codensity IO (IORef MLSState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLSState -> IO (IORef MLSState)
forall a. a -> IO (IORef a)
newIORef (MLSState -> Codensity IO (IORef MLSState))
-> Codensity IO MLSState -> Codensity IO (IORef MLSState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Codensity IO MLSState
mkMLSState
  IO Env -> Codensity IO Env
forall a. IO a -> Codensity IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> Codensity IO Env) -> IO Env -> Codensity IO Env
forall a b. (a -> b) -> a -> b
$ do
    IORef [(Int, String)]
pks <- [(Int, String)] -> IO (IORef [(Int, String)])
forall a. a -> IO (IORef a)
newIORef ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [String]
somePrekeys)
    IORef [String]
lpks <- [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [String]
someLastPrekeys
    Env -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Env
        { $sel:serviceMap:Env :: Map String ServiceMap
serviceMap = GlobalEnv -> Map String ServiceMap
gServiceMap GlobalEnv
ge,
          $sel:domain1:Env :: String
domain1 = GlobalEnv -> String
gDomain1 GlobalEnv
ge,
          $sel:domain2:Env :: String
domain2 = GlobalEnv -> String
gDomain2 GlobalEnv
ge,
          $sel:integrationTestHostName:Env :: String
integrationTestHostName = GlobalEnv -> String
gIntegrationTestHostName GlobalEnv
ge,
          $sel:federationV0Domain:Env :: String
federationV0Domain = GlobalEnv -> String
gFederationV0Domain GlobalEnv
ge,
          $sel:federationV1Domain:Env :: String
federationV1Domain = GlobalEnv -> String
gFederationV1Domain GlobalEnv
ge,
          $sel:dynamicDomains:Env :: [String]
dynamicDomains = GlobalEnv -> [String]
gDynamicDomains GlobalEnv
ge,
          $sel:defaultAPIVersion:Env :: Int
defaultAPIVersion = GlobalEnv -> Int
gDefaultAPIVersion GlobalEnv
ge,
          -- hardcode API versions for federated domains because they don't have
          -- latest things. Ensure we do not use development API versions in
          -- those domains.
          $sel:apiVersionByDomain:Env :: Map String Int
apiVersionByDomain =
            [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (GlobalEnv -> String
gFederationV0Domain GlobalEnv
ge, Int
4),
                (GlobalEnv -> String
gFederationV1Domain GlobalEnv
ge, Int
5)
              ],
          $sel:manager:Env :: Manager
manager = GlobalEnv -> Manager
gManager GlobalEnv
ge,
          $sel:servicesCwdBase:Env :: Maybe String
servicesCwdBase = GlobalEnv -> Maybe String
gServicesCwdBase GlobalEnv
ge,
          $sel:prekeys:Env :: IORef [(Int, String)]
prekeys = IORef [(Int, String)]
pks,
          $sel:lastPrekeys:Env :: IORef [String]
lastPrekeys = IORef [String]
lpks,
          $sel:mls:Env :: IORef MLSState
mls = IORef MLSState
mls,
          $sel:resourcePool:Env :: ResourcePool BackendResource
resourcePool = GlobalEnv
ge.gBackendResourcePool,
          $sel:rabbitMQConfig:Env :: RabbitMQConfig
rabbitMQConfig = GlobalEnv
ge.gRabbitMQConfig,
          $sel:timeOutSeconds:Env :: Int
timeOutSeconds = GlobalEnv
ge.gTimeOutSeconds
        }

allCiphersuites :: [Ciphersuite]
-- FUTUREWORK: add 0x0005 to this list once openmls supports it
allCiphersuites :: [Ciphersuite]
allCiphersuites = (String -> Ciphersuite) -> [String] -> [Ciphersuite]
forall a b. (a -> b) -> [a] -> [b]
map String -> Ciphersuite
Ciphersuite [String
"0x0001", String
"0xf031", String
"0x0002", String
"0x0007"]

mkMLSState :: Codensity IO MLSState
mkMLSState :: Codensity IO MLSState
mkMLSState = (forall b. (MLSState -> IO b) -> IO b) -> Codensity IO MLSState
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (MLSState -> IO b) -> IO b) -> Codensity IO MLSState)
-> (forall b. (MLSState -> IO b) -> IO b) -> Codensity IO MLSState
forall a b. (a -> b) -> a -> b
$ \MLSState -> IO b
k ->
  String -> (String -> IO b) -> IO b
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"mls" ((String -> IO b) -> IO b) -> (String -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \String
tmp -> do
    MLSState -> IO b
k
      MLSState
        { $sel:baseDir:MLSState :: String
baseDir = String
tmp,
          $sel:members:MLSState :: Set ClientIdentity
members = Set ClientIdentity
forall a. Monoid a => a
mempty,
          $sel:newMembers:MLSState :: Set ClientIdentity
newMembers = Set ClientIdentity
forall a. Monoid a => a
mempty,
          $sel:groupId:MLSState :: Maybe String
groupId = Maybe String
forall a. Maybe a
Nothing,
          $sel:convId:MLSState :: Maybe Value
convId = Maybe Value
forall a. Maybe a
Nothing,
          $sel:clientGroupState:MLSState :: Map ClientIdentity ClientGroupState
clientGroupState = Map ClientIdentity ClientGroupState
forall a. Monoid a => a
mempty,
          $sel:epoch:MLSState :: Word64
epoch = Word64
0,
          $sel:ciphersuite:MLSState :: Ciphersuite
ciphersuite = Ciphersuite
forall a. Default a => a
def,
          $sel:protocol:MLSState :: MLSProtocol
protocol = MLSProtocol
MLSProtocolMLS
        }

withAPIVersion :: Int -> App a -> App a
withAPIVersion :: forall a. Int -> App a -> App a
withAPIVersion Int
v = (Env -> Env) -> App a -> App a
forall a. (Env -> Env) -> App a -> App a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Env -> Env) -> App a -> App a) -> (Env -> Env) -> App a -> App a
forall a b. (a -> b) -> a -> b
$ \Env
e -> Env
e {defaultAPIVersion = v}