module Testlib.RunServices (main) where

import Control.Concurrent
import Control.Monad.Codensity
import Options.Applicative
import System.Directory
import System.Exit
import System.FilePath
import System.Posix (getWorkingDirectory)
import System.Process
import Testlib.Prelude
import Testlib.ResourcePool

parentDir :: FilePath -> Maybe FilePath
parentDir :: String -> Maybe String
parentDir String
path =
  let dirs :: [String]
dirs = String -> [String]
splitPath String
path
   in if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
dirs
        then Maybe String
forall a. Maybe a
Nothing
        else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinPath ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
dirs)

containsGit :: FilePath -> IO Bool
containsGit :: String -> IO Bool
containsGit String
path =
  String -> IO Bool
doesPathExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinPath [String
path, String
".git"]

findProjectRoot :: FilePath -> IO (Maybe FilePath)
findProjectRoot :: String -> IO (Maybe String)
findProjectRoot String
path = do
  Bool
c <- String -> IO Bool
containsGit String
path
  if Bool
c
    then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
path)
    else case String -> Maybe String
parentDir String
path of
      Maybe String
Nothing -> 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
      Just String
p -> String -> IO (Maybe String)
findProjectRoot String
p

data Opts = Opts
  { Opts -> Bool
withManualTestingOverrides :: Bool,
    Opts -> [String]
runSubprocess :: [String]
  }
  deriving (Int -> Opts -> ShowS
[Opts] -> ShowS
Opts -> String
(Int -> Opts -> ShowS)
-> (Opts -> String) -> ([Opts] -> ShowS) -> Show Opts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Opts -> ShowS
showsPrec :: Int -> Opts -> ShowS
$cshow :: Opts -> String
show :: Opts -> String
$cshowList :: [Opts] -> ShowS
showList :: [Opts] -> ShowS
Show)

optsParser :: Parser Opts
optsParser :: Parser Opts
optsParser =
  Bool -> [String] -> Opts
Opts
    (Bool -> [String] -> Opts)
-> Parser Bool -> Parser ([String] -> Opts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch
      ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"with-manual-testing-overrides"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Run services with settings tuned for manual app usage (not recommended for running integration tests)"
      )
    Parser ([String] -> Opts) -> Parser [String] -> Parser Opts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
      ( Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument
          ( String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"COMMAND_WITH_ARGS"
              Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"When specified, the command will be run after services have started and service will be killed after the command exits"
          )
      )

main :: IO ()
main :: IO ()
main = do
  String
cwd <- IO String
getWorkingDirectory
  Maybe String
mbProjectRoot <- String -> IO (Maybe String)
findProjectRoot String
cwd
  Opts
opts <- ParserInfo Opts -> IO Opts
forall a. ParserInfo a -> IO a
execParser (Parser Opts -> InfoMod Opts -> ParserInfo Opts
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser Opts
optsParser Parser Opts -> Parser (Opts -> Opts) -> Parser Opts
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Opts -> Opts)
forall a. Parser (a -> a)
helper) InfoMod Opts
forall a. InfoMod a
fullDesc)
  String
cfg <- case Maybe String
mbProjectRoot of
    Maybe String
Nothing -> String -> IO String
forall a. HasCallStack => String -> a
error String
"Could not find project root. Please make sure you call run-services from somewhere in wire-server."
    Just String
projectRoot ->
      String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinPath [String
projectRoot, String
"services/integration.yaml"]

  let run :: IO ()
run = case Opts
opts.runSubprocess of
        [] -> do
          String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"services started"
          IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound)
        [String]
_ -> do
          let cp :: CreateProcess
cp = String -> [String] -> CreateProcess
proc String
"sh" ([String
"-c", String
"exec \"$@\"", String
"--"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Opts
opts.runSubprocess)
          (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph

  Codensity IO Env -> forall b. (Env -> IO b) -> IO b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (String -> Codensity IO GlobalEnv
mkGlobalEnv String
cfg Codensity IO GlobalEnv
-> (GlobalEnv -> Codensity IO Env) -> Codensity IO Env
forall a b.
Codensity IO a -> (a -> Codensity IO b) -> Codensity IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GlobalEnv -> Codensity IO Env
mkEnv) ((Env -> IO ()) -> IO ()) -> (Env -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    Env -> App () -> IO ()
forall a. Env -> App a -> IO a
runAppWithEnv Env
env
      (App () -> IO ()) -> App () -> IO ()
forall a b. (a -> b) -> a -> b
$ Codensity App () -> App ()
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity
      (Codensity App () -> App ()) -> Codensity App () -> App ()
forall a b. (a -> b) -> a -> b
$ do
        ()
_modifyEnv <-
          (HasCallStack => BackendResource -> Codensity App ())
-> HasCallStack => [BackendResource] -> Codensity App ()
forall a.
(HasCallStack => a -> Codensity App ())
-> HasCallStack => [a] -> Codensity App ()
traverseConcurrentlyCodensity
            ( \BackendResource
r ->
                Codensity App String -> Codensity App ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
                  (Codensity App String -> Codensity App ())
-> Codensity App String -> Codensity App ()
forall a b. (a -> b) -> a -> b
$ if Opts
opts.withManualTestingOverrides
                    then HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
r ServiceOverrides
manualTestingOverrides
                    else HasCallStack =>
BackendResource -> ServiceOverrides -> Codensity App String
BackendResource -> ServiceOverrides -> Codensity App String
startDynamicBackend BackendResource
r ServiceOverrides
forall a. Monoid a => a
mempty
            )
            [BackendResource
backendA, BackendResource
backendB]
        IO () -> Codensity App ()
forall a. IO a -> Codensity App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
run

manualTestingOverrides :: ServiceOverrides
manualTestingOverrides :: ServiceOverrides
manualTestingOverrides =
  let smtpEndpoint :: Value
smtpEndpoint = [Pair] -> Value
object [String
"host" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"localhost", String
"port" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
2500 :: Int)]
      authSettings :: Value
authSettings =
        [Pair] -> Value
object
          [ String
"userTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
4838400 :: Int),
            String
"sessionTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
86400 :: Int),
            String
"accessTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
900 :: Int),
            String
"providerTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
900 :: Int),
            String
"legalHoldUserTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
4838400 :: Int),
            String
"legalHoldAccessTokenTimeout" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (Int
900 :: Int)
          ]
   in ServiceOverrides
forall a. Default a => a
def
        { brigCfg =
            mergeField "emailSMS.email.smtpEndpoint" smtpEndpoint
              >=> setField "emailSMS.email.smtpConnType" "plain"
              >=> removeField "emailSMS.email.sesQueue"
              >=> removeField "emailSMS.email.sesEndpoint"
              >=> mergeField "zauth.authSettings" authSettings
              >=> setField @_ @Int "optSettings.setActivationTimeout" 3600
              >=> setField @_ @Int "optSettings.setVerificationTimeout" 3600
              >=> setField @_ @Int "optSettings.setTeamInvitationTimeout" 3600
              >=> setField @_ @Int "optSettings.setUserCookieRenewAge" 1209600
              >=> removeField "optSettings.setSuspendInactiveUsers"
        }