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

module API.Team.Util where

import API.User.Util
import Bilge hiding (accept, head, timeout)
import Bilge.Assert
import Control.Lens ((^?))
import Control.Monad.Catch (MonadCatch)
import Data.Aeson
import Data.Aeson.Lens
import Data.ByteString.Conversion
import Data.Default
import Data.Id
import Data.Misc (Milliseconds)
import Data.Range
import Data.Set qualified as Set
import Data.Text.Encoding qualified as T
import Imports
import Network.Wai.Utilities.Error qualified as Error
import Test.Tasty.HUnit
import Util
import Web.Cookie (parseSetCookie, setCookieName)
import Wire.API.Conversation
import Wire.API.Conversation.Role
import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team
import Wire.API.Team hiding (newTeam)
import Wire.API.Team.Feature (FeatureStatus (..))
import Wire.API.Team.Feature qualified as Public
import Wire.API.Team.Invitation
import Wire.API.Team.Member qualified as Member
import Wire.API.Team.Permission
import Wire.API.Team.Role
import Wire.API.Team.SearchVisibility
import Wire.API.User
import Wire.API.User qualified as Public
import Wire.API.User.Activation

-- | FUTUREWORK: Remove 'createPopulatedBindingTeam', 'createPopulatedBindingTeamWithNames',
-- and rename 'createPopulatedBindingTeamWithNamesAndHandles' to 'createPopulatedBindingTeam'.
-- this makes understanding the tests easier because there are fewer setups that only differ
-- from real-world setups in being more artificial, and hopefully won't add too much run time.
createPopulatedBindingTeamWithNamesAndHandles ::
  (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) =>
  Brig ->
  Int ->
  m (TeamId, User, [User])
createPopulatedBindingTeamWithNamesAndHandles brig numMembers = do
  names <- replicateM numMembers randomName
  (tid, owner, mems) <- createPopulatedBindingTeamWithNames brig names
  membersWithHandle <- mapM (setRandomHandle brig) mems
  ownerWithHandle <- setRandomHandle brig owner
  pure (tid, ownerWithHandle, membersWithHandle)

createPopulatedBindingTeam ::
  (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) =>
  Brig ->
  Int ->
  m (TeamId, UserId, [User])
createPopulatedBindingTeam brig numMembers = do
  names <- replicateM numMembers randomName
  (tid, owner, others) <- createPopulatedBindingTeamWithNames brig names
  pure (tid, userId owner, others)

createPopulatedBindingTeamWithNames ::
  (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) =>
  Brig ->
  [Name] ->
  m (TeamId, User, [User])
createPopulatedBindingTeamWithNames brig names = do
  (inviter, tid) <- createUserWithTeam' brig
  invitees <- forM names $ \name -> do
    inviteeEmail <- randomEmail
    let invite = stdInvitationRequest inviteeEmail
    inv :: Invitation <-
      responseJsonError
        =<< postInvitation brig tid (userId inviter) invite
          <!! statusCode === const 201
    Just inviteeCode <- getInvitationCode brig tid inv.invitationId
    rsp2 <-
      post
        ( brig
            . path "/register"
            . contentJson
            . body (acceptWithName name inviteeEmail inviteeCode)
            . header "X-Forwarded-For" "127.0.0.42"
        )
        <!! const 201 === statusCode
    let invitee :: User = responseJsonUnsafe rsp2
    do
      let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2
      liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid)
    pure invitee
  pure (tid, inviter, invitees)

-- | Create user and binding team.
--
-- NB: the created user is the team owner.
createUserWithTeam :: (MonadIO m, MonadHttp m, MonadCatch m) => Brig -> m (UserId, TeamId)
createUserWithTeam brig = do
  (user, tid) <- createUserWithTeam' brig
  pure (userId user, tid)

-- | Create user and binding team.
--
-- NB: the created user is the team owner.
createUserWithTeam' :: (MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => Brig -> m (User, TeamId)
createUserWithTeam' brig = do
  e <- randomEmail
  n <- randomName
  let p =
        RequestBodyLBS . encode $
          object
            [ "name" .= n,
              "email" .= fromEmail e,
              "password" .= defPassword,
              "team" .= newTeam
            ]
  user <-
    responseJsonError
      =<< post (brig . path "/i/users" . contentJson . body p)
        <!! const 201 === statusCode
  let Just tid = userTeam user
  selfTeam <- userTeam . selfUser <$> getSelfProfile brig (userId user)
  liftIO $ assertBool "Team ID in self profile and team table do not match" (selfTeam == Just tid)
  pure (user, tid)

-- | Create a team member with given permissions.
createTeamMember ::
  Brig ->
  Galley ->
  -- | Team owner
  UserId ->
  -- | Team where the new user will be created
  TeamId ->
  -- | Permissions that the new user will have
  Permissions ->
  Http User
createTeamMember brig galley owner tid perm = do
  user <- inviteAndRegisterUser owner tid brig
  updatePermissions owner tid (userId user, perm) galley
  pure user

inviteAndRegisterUser ::
  (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) =>
  UserId ->
  TeamId ->
  Brig ->
  m User
inviteAndRegisterUser u tid brig = do
  inviteeEmail <- randomEmail
  let invite = stdInvitationRequest inviteeEmail
  inv :: Invitation <-
    responseJsonError
      =<< postInvitation brig tid u invite
        <!! statusCode === const 201
  Just inviteeCode <- getInvitationCode brig tid inv.invitationId
  rspInvitee <-
    post
      ( brig
          . path "/register"
          . contentJson
          . body (accept inviteeEmail inviteeCode)
          . header "X-Forwarded-For" "127.0.0.42"
      )
      <!! const 201
        === statusCode
  let Just invitee = responseJsonMaybe rspInvitee
  liftIO $ assertEqual "Team ID in registration and team table do not match" (Just tid) (userTeam invitee)
  selfTeam <- userTeam . selfUser <$> getSelfProfile brig (userId invitee)
  liftIO $ assertEqual "Team ID in self profile and team table do not match" selfTeam (Just tid)
  pure invitee

updatePermissions :: (HasCallStack) => UserId -> TeamId -> (UserId, Permissions) -> Galley -> Http ()
updatePermissions from tid (to, perm) galley =
  put
    ( galley
        . paths ["teams", toByteString' tid, "members"]
        . zUser from
        . zConn "conn"
        . Bilge.json changeMember
    )
    !!! const 200
      === statusCode
  where
    changeMember = Member.mkNewTeamMember to perm Nothing

createTeamConv :: (HasCallStack) => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId
createTeamConv = createTeamConvWithRole roleNameWireAdmin

createTeamConvWithRole :: (HasCallStack) => RoleName -> Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId
createTeamConvWithRole role g tid u us mtimer = do
  let tinfo = Just $ ConvTeamInfo tid
  let conv =
        NewConv
          us
          []
          Nothing
          (Set.fromList [])
          Nothing
          tinfo
          mtimer
          Nothing
          role
          BaseProtocolProteusTag
          GroupConversation
          False
          Nothing
          False
          Nothing
          def
  r <-
    post
      ( g
          . path "/conversations"
          . zUser u
          . zConn "conn"
          . contentJson
          . lbytes (encode conv)
      )
      <!! const 201
        === statusCode
  maybe (error "invalid conv id") pure $
    fromByteString $
      getHeader' "Location" r

deleteTeamConv :: (HasCallStack) => Galley -> TeamId -> ConvId -> UserId -> Http ()
deleteTeamConv g tid cid u = do
  delete
    ( g
        . paths ["teams", toByteString' tid, "conversations", toByteString' cid]
        . zUser u
        . zConn "conn"
    )
    !!! const 200
      === statusCode

deleteTeam :: (HasCallStack) => Galley -> TeamId -> UserId -> Http ()
deleteTeam g tid u = do
  delete
    ( g
        . paths ["teams", toByteString' tid]
        . zUser u
        . zConn "conn"
        . json (newTeamDeleteData $ Just Util.defPassword)
    )
    !!! const 202
      === statusCode

newTeam :: NewTeam
newTeam = newNewTeam (unsafeRange "teamName") DefaultIcon

putLegalHoldEnabled :: (HasCallStack) => TeamId -> FeatureStatus -> Galley -> Http ()
putLegalHoldEnabled tid enabled g = do
  void . put $
    g
      . paths ["i", "teams", toByteString' tid, "features", "legalhold"]
      . contentJson
      . lbytes (encode (Public.Feature enabled Public.LegalholdConfig))
      . expect2xx

putLHWhitelistTeam :: (HasCallStack) => Galley -> TeamId -> Http ResponseLBS
putLHWhitelistTeam galley tid = do
  put
    ( galley
        . paths ["i", "legalhold", "whitelisted-teams", toByteString' tid]
    )

accept :: EmailAddress -> InvitationCode -> RequestBody
accept = acceptWithName (Name "Bob")

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

extAccept :: EmailAddress -> Name -> Phone -> ActivationCode -> InvitationCode -> RequestBody
extAccept email name phone phoneCode code =
  RequestBodyLBS . encode $
    object
      [ "name" .= name,
        "email" .= fromEmail email,
        "password" .= defPassword,
        "team_code" .= code,
        "phone" .= phone,
        "phone_code" .= phoneCode,
        "team_code" .= code
      ]

register :: EmailAddress -> NewTeam -> Brig -> Http (Response (Maybe LByteString))
register e t brig =
  post
    ( brig
        . path "/register"
        . contentJson
        . body
          ( RequestBodyLBS . encode $
              object
                [ "name" .= ("Bob" :: Text),
                  "email" .= fromEmail e,
                  "password" .= defPassword,
                  "team" .= t
                ]
          )
        . header "X-Forwarded-For" "127.0.0.42"
    )

register' :: EmailAddress -> NewTeam -> ActivationCode -> Brig -> Http (Response (Maybe LByteString))
register' e t c brig =
  post
    ( brig
        . path "/register"
        . contentJson
        . body
          ( RequestBodyLBS . encode $
              object
                [ "name" .= ("Bob" :: Text),
                  "email" .= fromEmail e,
                  "email_code" .= c,
                  "password" .= defPassword,
                  "team" .= t
                ]
          )
        . header "X-Forwarded-For" "127.0.0.42"
    )

getInvitationInfo :: Brig -> InvitationCode -> (MonadIO m, MonadHttp m) => m (Maybe Invitation)
getInvitationInfo brig c = do
  r <-
    get $
      brig
        . path "/teams/invitations/info"
        . queryItem "code" (toByteString' c)
  pure . decode . fromMaybe "" $ responseBody r

getInvitation :: Brig -> TeamId -> InvitationId -> UserId -> Http ResponseLBS
getInvitation brig tid iid uid =
  get (brig . paths ["teams", toByteString' tid, "invitations", toByteString' iid] . zUser uid)

deleteInvitation :: Brig -> TeamId -> InvitationId -> UserId -> Http ()
deleteInvitation brig tid iid uid =
  delete (brig . paths ["teams", toByteString' tid, "invitations", toByteString' iid] . zUser uid) !!! const 200 === statusCode

postInvitation ::
  (MonadHttp m, HasCallStack) =>
  Brig ->
  TeamId ->
  UserId ->
  InvitationRequest ->
  m ResponseLBS
postInvitation brig t u i =
  post $
    brig
      . paths ["teams", toByteString' t, "invitations"]
      . contentJson
      . body (RequestBodyLBS $ encode i)
      . zAuthAccess u "conn"

suspendTeam :: Brig -> TeamId -> Http (Response (Maybe LByteString))
suspendTeam brig t =
  post $
    brig
      . paths ["i", "teams", toByteString' t, "suspend"]
      . contentJson

unsuspendTeam :: Brig -> TeamId -> Http ResponseLBS
unsuspendTeam brig t =
  post $
    brig
      . paths ["i", "teams", toByteString' t, "unsuspend"]
      . contentJson

getTeam :: (HasCallStack, MonadIO m, MonadHttp m, HasCallStack, MonadCatch m) => Galley -> TeamId -> m Team.TeamData
getTeam galley t =
  responseJsonError =<< get (galley . paths ["i", "teams", toByteString' t])

getInvitationCode ::
  (MonadIO m, MonadHttp m, HasCallStack) =>
  Brig ->
  TeamId ->
  InvitationId ->
  m (Maybe InvitationCode)
getInvitationCode brig t ref = 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 (maybe (error "No code?") T.encodeUtf8 (lbs ^? key "code" . _String))

assertNoInvitationCode :: (HasCallStack) => Brig -> TeamId -> InvitationId -> (MonadIO m, MonadHttp m, MonadCatch m) => m ()
assertNoInvitationCode brig t i =
  get
    ( brig
        . path "/i/teams/invitation-code"
        . queryItem "team" (toByteString' t)
        . queryItem "invitation_id" (toByteString' i)
    )
    !!! do
      const 400 === statusCode
      const (Just "invalid-invitation-code") === fmap Error.label . responseJsonMaybe

isActivatedUser :: UserId -> Brig -> Http Bool
isActivatedUser uid brig = do
  resp <- get (brig . path "/i/users" . queryItem "ids" (toByteString' uid) . expect2xx)
  pure $ case responseJsonMaybe @[User] resp of
    Just (_ : _) -> True
    _ -> False

stdInvitationRequest :: EmailAddress -> InvitationRequest
stdInvitationRequest = stdInvitationRequest' Nothing Nothing

stdInvitationRequest' :: Maybe Locale -> Maybe Role -> EmailAddress -> InvitationRequest
stdInvitationRequest' loc role email =
  InvitationRequest loc role Nothing email True

setTeamTeamSearchVisibilityAvailable :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> TeamId -> FeatureStatus -> m ()
setTeamTeamSearchVisibilityAvailable galley tid status =
  put
    ( galley
        . paths ["i/teams", toByteString' tid, "features/searchVisibility"]
        . contentJson
        . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityAvailableConfig)
    )
    !!! do
      const 200 === statusCode

setTeamSearchVisibility :: (HasCallStack) => Galley -> TeamId -> TeamSearchVisibility -> Http ()
setTeamSearchVisibility galley tid typ =
  put
    ( galley
        . paths ["i/teams", toByteString' tid, "search-visibility"]
        . contentJson
        . body (RequestBodyLBS . encode $ TeamSearchVisibilityView typ)
    )
    !!! do
      const 204 === statusCode

setTeamSearchVisibilityInboundAvailable :: (HasCallStack, MonadHttp m, MonadIO m, MonadCatch m) => Galley -> TeamId -> FeatureStatus -> m ()
setTeamSearchVisibilityInboundAvailable galley tid status =
  put
    ( galley
        . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SearchVisibilityInboundConfig]
        . contentJson
        . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityInboundConfig)
    )
    !!! do
      const 200 === statusCode

setUserEmail :: Brig -> UserId -> UserId -> EmailAddress -> Http ResponseLBS
setUserEmail brig from uid email = do
  put
    ( brig
        . paths ["users", toByteString' uid, "email"]
        . zUser from
        . zConn "conn"
        . contentJson
        . body (RequestBodyLBS . encode $ Public.EmailUpdate email)
    )
