content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
  -- Disabling to stop warnings on HasCallStack
  {-# OPTIONS_GHC -Wno-redundant-constraints #-}
  
  -- This file is part of the Wire Server implementation.
  --
  -- Copyright (C) 2022 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/>.
  
  -- FUTUREWORK: this is all copied from galley and spar. Maybe at some point reduce duplication?
  module Test.Federator.Util where
  
  import Bilge
  import Bilge.Assert
  import Control.Exception
  import Control.Lens hiding ((.=))
  import Control.Monad.Catch
  import Crypto.Random.Types
  import Data.Aeson
  import Data.Aeson.TH
  import Data.Aeson.Types qualified as Aeson
  import Data.ByteString.Char8 qualified as C8
  import Data.Default (def)
  import Data.Id
  import Data.Misc
  import Data.String.Conversions
  import Data.Text qualified as Text
  import Data.UUID qualified as UUID
  import Data.UUID.V4 qualified as UUID
  import Data.Yaml qualified as Yaml
  import Federator.Options
  import Federator.Run
  import Imports
  import Network.Connection qualified
  import Network.HTTP.Client.TLS
  import OpenSSL.Session (SSLContext)
  import Options.Applicative qualified as OPA
  import Polysemy
  import Polysemy.Error
  import System.Random
  import Test.Federator.JSON
  import Test.Tasty.HUnit
  import Util.Options (Endpoint)
  import Util.Options qualified as O
  import Wire.API.User
  import Wire.API.User.Auth
  
  type BrigReq = Request -> Request
  
  type CargoholdReq = Request -> Request
  
  newtype TestFederator m a = TestFederator {unwrapTestFederator :: ReaderT TestEnv m a}
    deriving newtype
      ( Functor,
        Applicative,
        Monad,
        MonadIO,
        MonadTrans,
        MonadReader TestEnv,
        MonadFail,
        MonadThrow,
        MonadCatch,
        MonadMask
      )
  
  instance (MonadRandom m) => MonadRandom (TestFederator m) where
    getRandomBytes = lift . getRandomBytes
  
  instance (MonadIO m) => MonadHttp (TestFederator m) where
    handleRequestWithCont req handler = do
      manager <- _teMgr <$> ask
      liftIO $ withResponse req manager handler
  
  runTestFederator :: TestEnv -> TestFederator IO a -> IO a
  runTestFederator env = flip runReaderT env . unwrapTestFederator
  
  -- | See 'mkEnv' about what's in here.
  data TestEnv = TestEnv
    { _teMgr :: Manager,
      _teSSLContext :: SSLContext,
      _teBrig :: BrigReq,
      _teCargohold :: CargoholdReq,
      -- | federator config
      _teOpts :: Opts,
      -- | integration test config
      _teTstOpts :: IntegrationConfig,
      -- | Settings passed to the federator
      _teSettings :: RunSettings
    }
  
  type Select = TestEnv -> (Request -> Request)
  
  data IntegrationConfig = IntegrationConfig
    { brig :: Endpoint,
      cargohold :: Endpoint,
      federatorExternal :: Endpoint,
      nginxIngress :: Endpoint,
      originDomain :: Text
    }
    deriving (Show, Generic)
  
  deriveFromJSON deriveJSONOptions ''IntegrationConfig
  
  makeLenses ''TestEnv
  
  -- | Call 'mkEnv' with options from config files.
  mkEnvFromOptions :: IO TestEnv
  mkEnvFromOptions = do
    let desc = "Federator - SSO Service Integration Test Suite"
    (integrationCfgFilePath, cfgFilePath) <- OPA.execParser (OPA.info (OPA.helper <*> cliOptsParser) (OPA.header desc <> OPA.fullDesc))
    integrationOpts :: IntegrationConfig <- Yaml.decodeFileEither integrationCfgFilePath >>= either (error . show) pure
    serviceOpts :: Opts <- Yaml.decodeFileEither cfgFilePath >>= either (throwIO . ErrorCall . show) pure
    mkEnv integrationOpts serviceOpts
  
  -- | Accept config file locations as cli options.
  cliOptsParser :: OPA.Parser (String, String)
  cliOptsParser =
    (,)
      <$> OPA.strOption
        ( OPA.long "integration-config"
            <> OPA.short 'i'
            <> OPA.help "Integration config to load"
            <> OPA.showDefault
            <> OPA.value defaultIntPath
        )
      <*> OPA.strOption
        ( OPA.long "service-config"
            <> OPA.short 's'
            <> OPA.help "Federator application config to load"
            <> OPA.showDefault
            <> OPA.value defaultFederatorPath
        )
    where
      defaultIntPath = "/etc/wire/integration/integration.yaml"
      defaultFederatorPath = "/etc/wire/federator/conf/federator.yaml"
  
  -- | Create an environment for integration tests from integration and federator config files.
  mkEnv :: (HasCallStack) => IntegrationConfig -> Opts -> IO TestEnv
  mkEnv _teTstOpts _teOpts = do
    let managerSettings = mkManagerSettings (Network.Connection.TLSSettingsSimple True False False def) Nothing
    _teMgr :: Manager <- newManager managerSettings
    let _teBrig = endpointToReq _teTstOpts.brig
        _teCargohold = endpointToReq _teTstOpts.cargohold
    -- _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts)
    _teSSLContext <- mkTLSSettingsOrThrow _teOpts.optSettings
    let _teSettings = _teOpts.optSettings
    pure TestEnv {..}
  
  endpointToReq :: Endpoint -> (Bilge.Request -> Bilge.Request)
  endpointToReq ep = Bilge.host (cs ep.host) . Bilge.port ep.port
  
  -- All the code below is copied from brig-integration tests
  -- FUTUREWORK: This should live in another package and shared by all the integration tests
  
  randomUser ::
    (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) =>
    BrigReq ->
    m User
  randomUser = randomUser' True
  
  randomUser' ::
    (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) =>
    Bool ->
    BrigReq ->
    m User
  randomUser' hasPwd brig = do
    n <- fromName <$> randomName
    createUser hasPwd n brig
  
  createUser ::
    (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) =>
    Bool ->
    Text ->
    BrigReq ->
    m User
  createUser hasPwd name brig = do
    r <-
      postUser' hasPwd True name True False Nothing Nothing brig
        <!! const 201 === statusCode
    responseJsonError r
  
  -- | Use @postUser' True False@ instead of 'postUser' if you want to send broken bodies to test error
  -- messages.  Or @postUser' False True@ if you want to validate the body, but not set a password.
  postUser' ::
    (MonadIO m, MonadHttp m, HasCallStack) =>
    Bool ->
    Bool ->
    Text ->
    Bool ->
    Bool ->
    Maybe UserSSOId ->
    Maybe TeamId ->
    BrigReq ->
    m ResponseLBS
  postUser' hasPassword validateBody name haveEmail havePhone ssoid teamid brig = do
    email <-
      if haveEmail
        then Just <$> randomEmail
        else pure Nothing
    postUserWithEmail hasPassword validateBody name email havePhone ssoid teamid brig
  
  -- | More flexible variant of 'createUserUntrustedEmail' (see above).
  postUserWithEmail ::
    (MonadIO m, MonadHttp m, HasCallStack) =>
    Bool ->
    Bool ->
    Text ->
    Maybe EmailAddress ->
    Bool ->
    Maybe UserSSOId ->
    Maybe TeamId ->
    BrigReq ->
    m ResponseLBS
  postUserWithEmail hasPassword validateBody name email havePhone ssoid teamid brig = do
    phone <-
      if havePhone
        then Just <$> randomPhone
        else pure Nothing
    let o =
          object $
            [ "name" .= name,
              "email" .= (fromEmail <$> email),
              "phone" .= phone,
              "cookie" .= defCookieLabel,
              "sso_id" .= ssoid,
              "team_id" .= teamid
            ]
              <> ["password" .= defPassword | hasPassword]
        p = case Aeson.parse parseJSON o of
          Aeson.Success (p_ :: NewUser PlainTextPassword8) -> p_
          bad -> error $ show (bad, o)
        bdy = if validateBody then Bilge.json p else Bilge.json o
    post (brig . path "/i/users" . bdy)
  
  putHandle ::
    (MonadHttp m, HasCallStack) =>
    BrigReq ->
    UserId ->
    Text ->
    m ResponseLBS
  putHandle brig usr h =
    put $
      brig
        . path "/self/handle"
        . contentJson
        . body payload
        . zUser usr
        . zConn "conn"
    where
      payload = RequestBodyLBS . encode $ object ["handle" .= h]
  
  randomName :: (MonadIO m) => m Name
  randomName = randomNameWithMaxLen 128
  
  -- | For testing purposes we restrict ourselves to code points in the
  -- Basic Multilingual Plane that are considered to be numbers, letters,
  -- punctuation or symbols and ensure the name starts with a "letter".
  -- That is in order for the name to be searchable at all, since the standard
  -- ElasticSearch tokenizer may otherwise produce an empty list of tokens,
  -- e.g. if the name is entirely made of characters from categories that
  -- the standard tokenizer considers as word boundaries (or which are
  -- simply unassigned code points), yielding no tokens to match and thus
  -- no results in search queries.
  randomNameWithMaxLen :: (MonadIO m) => Word -> m Name
  randomNameWithMaxLen maxLen = liftIO $ do
    len <- randomRIO (2, maxLen)
    chars <- fill len []
    pure $ Name (Text.pack chars)
    where
      fill 0 characters = pure characters
      fill 1 characters = (: characters) <$> randLetter
      fill n characters = do
        c <- randChar
        if isLetter c || isNumber c || isPunctuation c || isSymbol c
          then fill (n - 1) (c : characters)
          else fill n characters
      randChar = chr <$> randomRIO (0x0000, 0xFFFF)
      randLetter = do
        c <- randChar
        if isLetter c
          then pure c
          else randLetter
  
  randomPhone :: (MonadIO m) => m Phone
  randomPhone = liftIO $ do
    nrs <- map show <$> replicateM 14 (randomRIO (0, 9) :: IO Int)
    let phone = parsePhone . Text.pack $ "+0" ++ concat nrs
    pure $ fromMaybe (error "Invalid random phone#") phone
  
  defPassword :: PlainTextPassword6
  defPassword = plainTextPassword6Unsafe "topsecretdefaultpassword"
  
  defCookieLabel :: CookieLabel
  defCookieLabel = CookieLabel "auth"
  
  -- | Generate emails that are in the trusted whitelist of domains whose @+@ suffices count for email
  -- disambiguation.  See also: 'Brig.Email.mkEmailKey'.
  randomEmail :: (MonadIO m) => m EmailAddress
  randomEmail = mkSimulatorEmail "success"
  
  mkSimulatorEmail :: (MonadIO m) => Text -> m EmailAddress
  mkSimulatorEmail loc = mkEmailRandomLocalSuffix (loc <> "@simulator.amazonses.com")
  
  mkEmailRandomLocalSuffix :: (MonadIO m) => Text -> m EmailAddress
  mkEmailRandomLocalSuffix e = do
    uid <- liftIO UUID.nextRandom
    case emailAddressText e of
      Just mail -> pure $ unsafeEmailAddress ((localPart mail) <> "+" <> UUID.toASCIIBytes uid) (domainPart mail)
      Nothing -> error $ "Invalid email address: " ++ Text.unpack e
  
  zUser :: UserId -> Bilge.Request -> Bilge.Request
  zUser = header "Z-User" . C8.pack . show
  
  zConn :: ByteString -> Bilge.Request -> Bilge.Request
  zConn = header "Z-Connection"
  
  randomHandle :: (MonadIO m) => m Text
  randomHandle = liftIO $ do
    nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z
    pure (Text.pack (map chr nrs))
  
  assertNoError :: (Show e, Member (Embed IO) r) => Sem (Error e ': r) x -> Sem r x
  assertNoError =
    runError >=> \case
      Left err -> embed @IO . assertFailure $ "Unexpected error: " <> show err
      Right x -> pure x
  