{-# LANGUAGE OverloadedRecordDot #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

-- 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/>.

module Util where

import Bilge
import Bilge.Assert
import Control.Applicative
import Control.Lens hiding ((.=))
import Control.Monad.Catch
import Control.Retry (constantDelay, exponentialBackoff, retrying)
import Data.Aeson
import Data.Aeson.Lens
import Data.ByteString.Conversion
import Data.Id
import Data.Misc
import Data.Qualified
import Data.Range
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Tuple.Extra
import Data.UUID qualified as UUID
import Data.UUID.V4
import Imports
import System.Random
import Test.Tasty.HUnit
import TestSetup
import UnliftIO.Retry (limitRetries, recoverAll)
import Web.Cookie
import Wire.API.Team
import Wire.API.Team.Invitation
import Wire.API.Team.Member as Team
import Wire.API.Team.Role
import Wire.API.User as User

eventually :: (MonadIO m, MonadMask m, MonadUnliftIO m) => m a -> m a
eventually = recoverAll (limitRetries 7 <> exponentialBackoff 50000) . const

createTeamWithNMembers :: (HasCallStack) => Int -> TestM (UserId, TeamId, [UserId])
createTeamWithNMembers n = do
  (owner, tid) <- createBindingTeam
  mems <- replicateM n $ do
    mem <- addUserToTeam owner tid
    pure (mem ^. Team.userId)
  pure (owner, tid, mems)

createBindingTeam :: (HasCallStack) => TestM (UserId, TeamId)
createBindingTeam = do
  first User.userId <$> createBindingTeam'

createBindingTeam' :: (HasCallStack) => TestM (User, TeamId)
createBindingTeam' = do
  owner <- randomTeamCreator'
  refreshIndex
  pure (owner, fromMaybe (error "createBindingTeam: no team id") (owner.userTeam))

randomTeamCreator' :: (HasCallStack) => TestM User
randomTeamCreator' = randomUser'' True True True

randomUser :: (HasCallStack) => TestM UserId
randomUser = qUnqualified <$> randomUser' False True True

randomUser' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (Qualified UserId)
randomUser' isCreator hasPassword hasEmail = userQualifiedId <$> randomUser'' isCreator hasPassword hasEmail

randomUser'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM User
randomUser'' isCreator hasPassword hasEmail = selfUser <$> randomUserProfile' isCreator hasPassword hasEmail

randomUserProfile' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM SelfProfile
randomUserProfile' isCreator hasPassword hasEmail = randomUserProfile'' isCreator hasPassword hasEmail <&> fst

randomUserProfile'' :: (HasCallStack) => Bool -> Bool -> Bool -> TestM (SelfProfile, EmailAddress)
randomUserProfile'' isCreator hasPassword hasEmail = do
  b <- view tsBrig
  e <- liftIO randomEmail
  let pl =
        object $
          ["name" .= fromEmail e]
            <> ["password" .= defPassword | hasPassword]
            <> ["email" .= fromEmail e | hasEmail]
            <> ["team" .= newNewTeam (unsafeRange "teamName") DefaultIcon | isCreator]
  (,e) . responseJsonUnsafe <$> (post (b . path "/i/users" . Bilge.json pl) <!! const 201 === statusCode)

randomEmailUser :: (HasCallStack) => TestM (UserId, EmailAddress)
randomEmailUser = randomUserProfile'' False False True <&> first (User.userId . selfUser)

defPassword :: PlainTextPassword8
defPassword = plainTextPassword8Unsafe "topsecretdefaultpassword"

randomEmail :: (MonadIO m) => m EmailAddress
randomEmail = do
  uid <- liftIO nextRandom
  pure $ unsafeEmailAddress ("success+" <> UUID.toASCIIBytes uid) "simulator.amazonses.com"

setHandle :: UserId -> Text -> TestM ()
setHandle uid h = do
  b <- view tsBrig
  put
    ( b
        . paths ["/i/users", toByteString' uid, "handle"]
        . Bilge.json (HandleUpdate h)
    )
    !!! do
      const 200 === statusCode

randomHandle :: (MonadIO m) => m Text
randomHandle = liftIO $ do
  nrs <- replicateM 21 (randomRIO (97, 122)) -- a-z
  pure (Text.pack (map chr nrs))

refreshIndex :: TestM ()
refreshIndex = do
  brig <- view tsBrig
  post (brig . path "/i/index/refresh") !!! const 200 === statusCode

addUserToTeam :: (HasCallStack) => UserId -> TeamId -> TestM TeamMember
addUserToTeam = addUserToTeamWithRole Nothing

addUserToTeamWithRole :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM TeamMember
addUserToTeamWithRole role inviter tid = do
  (inv, rsp2) <- addUserToTeamWithRole' role inviter tid
  let invitee :: User = responseJsonUnsafe rsp2
      inviteeId = User.userId invitee
  let invmeta = Just (inviter, inv.createdAt)
  mem <- getTeamMember inviter tid inviteeId
  liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation)
  let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2
  liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid)
  pure mem

addUserToTeamWithRole' :: (HasCallStack) => Maybe Role -> UserId -> TeamId -> TestM (Invitation, ResponseLBS)
addUserToTeamWithRole' role inviter tid = do
  brig <- view tsBrig
  email <- randomEmail
  let invite = InvitationRequest Nothing role Nothing email True
  invResponse <- postInvitation tid inviter invite
  inv <- responseJsonError invResponse
  inviteeCode <- getInvitationCode tid inv.invitationId
  r <-
    post
      ( brig
          . path "/register"
          . contentJson
          . header "X-Forwarded-For" "127.0.0.42"
          . body (acceptInviteBody email inviteeCode)
      )
  pure (inv, r)

acceptInviteBody :: EmailAddress -> InvitationCode -> RequestBody
acceptInviteBody email code =
  RequestBodyLBS . encode $
    object
      [ "name" .= Name "bob",
        "email" .= fromEmail email,
        "password" .= defPassword,
        "team_code" .= code
      ]

getInvitationCode :: (HasCallStack) => TeamId -> InvitationId -> TestM InvitationCode
getInvitationCode t ref = do
  brig <- view tsBrig
  let getm :: TestM (Maybe InvitationCode)
      getm = do
        r <-
          get
            ( brig
                . path "/i/teams/invitation-code"
                . queryItem "team" (toByteString' t)
                . queryItem "invitation_id" (toByteString' ref)
            )
        let lbs = fromMaybe "" $ responseBody r
        pure $ fromByteString . Text.encodeUtf8 =<< lbs ^? key "code" . _String

  fromMaybe (error "No code?")
    <$> retrying
      (constantDelay 800000 <> limitRetries 3)
      (\_ -> pure . isNothing)
      (const getm)

postInvitation :: TeamId -> UserId -> InvitationRequest -> TestM ResponseLBS
postInvitation t u i = do
  brig <- view tsBrig
  post $
    brig
      . paths ["teams", toByteString' t, "invitations"]
      . contentJson
      . body (RequestBodyLBS $ encode i)
      . zAuthAccess u "conn"

zAuthAccess :: UserId -> ByteString -> (Request -> Request)
zAuthAccess u conn =
  zUser u
    . zConn conn
    . zType "access"

zUser :: UserId -> Request -> Request
zUser = header "Z-User" . toByteString'

zConn :: ByteString -> Request -> Request
zConn = header "Z-Connection"

zType :: ByteString -> Request -> Request
zType = header "Z-Type"

getTeamMember :: (HasCallStack) => UserId -> TeamId -> UserId -> TestM TeamMember
getTeamMember getter tid gettee = do
  g <- view tsGalley
  getTeamMember' g getter tid gettee

getTeamMember' :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> UserId -> TeamId -> UserId -> m TeamMember
getTeamMember' g getter tid gettee = do
  r <-
    get (g . paths ["teams", toByteString' tid, "members", toByteString' gettee] . zUser getter)
      <!! const 200 === statusCode
  responseJsonError r
