{-# OPTIONS_GHC -Wno-incomplete-uni-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 API.Team
  ( tests,
  )
where

import API.Search.Util qualified as SearchUtil
import API.Team.Util
import API.User.Util as Util
import Bilge hiding (accept, head, timeout)
import Bilge qualified
import Bilge.Assert
import Brig.Options qualified as Opt
import Control.Arrow ((&&&))
import Control.Lens hiding ((.=))
import Control.Monad.Catch (MonadCatch)
import Data.Aeson
import Data.ByteString.Conversion
import Data.ByteString.Lazy (toStrict)
import Data.Default (def)
import Data.Either.Extra (eitherToMaybe)
import Data.Id
import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis)
import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldDisabled))
import Data.String.Conversions (cs)
import Data.Text qualified as Text
import Data.Text.Ascii qualified as Ascii
import Data.UUID qualified as UUID (fromString)
import Data.UUID.V4 qualified as UUID
import Imports
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import Network.Wai.Utilities.Error qualified as Error
import Numeric.Natural (Natural)
import Test.Tasty hiding (Timeout)
import Test.Tasty.Cannon qualified as WS
import Test.Tasty.HUnit
import URI.ByteString
import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcurrently)
import Util
import Util.AWS as Util
import Util.Timeout
import Web.Cookie (parseSetCookie, setCookieName)
import Wire.API.Asset
import Wire.API.Connection
import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team
import Wire.API.Team hiding (newTeam)
import Wire.API.Team.Feature
import Wire.API.Team.Feature qualified as Public
import Wire.API.Team.Invitation
import Wire.API.Team.Member hiding (invitation, userId)
import Wire.API.Team.Member qualified as Member
import Wire.API.Team.Permission
import Wire.API.Team.Role
import Wire.API.Team.Size
import Wire.API.User
import Wire.API.User.Auth
import Wire.API.User.Client (ClientType (PermanentClientType))

newtype TeamSizeLimit = TeamSizeLimit Word32

tests :: Opt.Opts -> Manager -> Nginz -> Brig -> Cannon -> Galley -> UserJournalWatcher -> IO TestTree
tests conf m n b c g aws = do
  let tl = TeamSizeLimit conf.settings.maxTeamSize
  let it = conf.settings.teamInvitationTimeout
  pure $
    testGroup
      "team"
      [ testGroup "invitation" $
          [ test m "post /teams/:tid/invitations - 201" $ testInvitationEmail b,
            test m "get /teams/:tid/invitations/:iid - 200" $ testGetInvitation b,
            test m "delete /teams/:tid/invitations/:iid - 200" $ testDeleteInvitation b,
            test m "post /teams/:tid/invitations - invitation url" $ testInvitationUrl conf b,
            test m "post /teams/:tid/invitations - no invitation url" $ testNoInvitationUrl conf b,
            test m "post /teams/:tid/invitations - email lookup" $ testInvitationEmailLookup b,
            test m "post /teams/:tid/invitations - email lookup nginz" $ testInvitationEmailLookupNginz b n,
            test m "post /teams/:tid/invitations - email lookup register" $ testInvitationEmailLookupRegister b,
            test m "post /teams/:tid/invitations - 403 no permission" $ testInvitationNoPermission b,
            test m "post /teams/:tid/invitations - 403 too many pending" $ testInvitationTooManyPending conf b tl,
            test m "post /teams/:tid/invitations - roles" $ testInvitationRoles b g,
            test m "post /register - 201 accepted" $ testInvitationEmailAccepted b g,
            test m "post /register user & team - 201 accepted" $ testCreateTeam b g aws,
            test m "post /register user & team - 201 preverified" $ testCreateTeamPreverified b g aws,
            test m "post /register - 400 no passwordless" $ testTeamNoPassword b,
            test m "post /register - 400 code already used" $ testInvitationCodeExists b,
            test m "post /register - 400 bad code" $ testInvitationInvalidCode b,
            test m "post /register - 400 no wireless" $ testInvitationCodeNoIdentity b,
            test m "post /register - 400 mutually exclusive" $ testInvitationMutuallyExclusive b,
            test m "post /register - 403 too many members" $ testInvitationTooManyMembers b g tl,
            test m "get /teams/:tid/invitations - 200 (paging)" $ testInvitationPaging conf b,
            test m "get /teams/:tid/invitations/info - 200" $ testInvitationInfo b,
            test m "get /teams/:tid/invitations/info - 400" $ testInvitationInfoBadCode b,
            test m "get /teams/:tid/invitations/info - 400 expired" $ testInvitationInfoExpired b it,
            -- "get /i/teams/invitations/by-email?email=..." is tested in 'testCreateUserNoIdP', 'testCreateUserTimeout'
            -- in spar's integration tests, module "Test.Spar.Scim.UserSpec"
            test m "post /i/teams/:tid/suspend - 200" $ testSuspendTeam b,
            test m "put /self - 200 update events" $ testUpdateEvents b c,
            test m "delete /self - 200 (ensure no orphan teams)" $ testDeleteTeamUser b g,
            test m "post /connections - 403 (same binding team)" $ testConnectionSameTeam b
          ],
        testGroup "sso" $
          [ test m "post /i/users  - 201 internal-SSO" $ testCreateUserInternalSSO b g,
            test m "delete /i/users/:uid - 202 internal-SSO (ensure no orphan teams)" $ testDeleteUserSSO b g,
            test m "get /i/teams/:tid/is-team-owner/:uid" $ testSSOIsTeamOwner b g,
            test m "2FA disabled for SSO user" $ test2FaDisabledForSsoUser b g
          ],
        testGroup "size" $
          [ test m "get /i/teams/:tid/size" $ testTeamSizeInternal b,
            test m "get /teams/:tid/size" $ testTeamSizePublic b
          ]
      ]

testTeamSizeInternal :: Brig -> Http ()
testTeamSizeInternal brig = do
  testTeamSize brig (\tid _ -> brig . paths ["i", "teams", toByteString' tid, "size"])

testTeamSizePublic :: Brig -> Http ()
testTeamSizePublic brig = do
  testTeamSize brig (\tid uid -> brig . paths ["teams", toByteString' tid, "size"] . zUser uid)

testTeamSize :: Brig -> (TeamId -> UserId -> Request -> Request) -> Http ()
testTeamSize brig req = do
  (tid, owner, _) <- createPopulatedBindingTeam brig 10
  SearchUtil.refreshIndex brig
  -- 10 Team Members and an admin
  let expectedSize = 11
  assertSize tid owner expectedSize

  -- Even suspended teams should report correct size
  suspendTeam brig tid !!! const 200 === statusCode
  SearchUtil.refreshIndex brig
  assertSize tid owner expectedSize
  where
    assertSize :: (HasCallStack) => TeamId -> UserId -> Natural -> Http ()
    assertSize tid uid expectedSize =
      void $
        get (req tid uid) <!! do
          const 200 === statusCode
          (const . Right $ TeamSize expectedSize 0) === responseJsonEither

-------------------------------------------------------------------------------
-- Invitation Tests

testUpdateEvents :: Brig -> Cannon -> Http ()
testUpdateEvents brig cannon = do
  (alice, tid) <- createUserWithTeam brig
  inviteeEmail <- randomEmail
  -- invite and register Bob
  let invite = stdInvitationRequest inviteeEmail
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid alice invite
  Just inviteeCode <- getInvitationCode brig tid inv.invitationId
  rsp2 <-
    post
      ( brig
          . path "/register"
          . contentJson
          . body (accept inviteeEmail inviteeCode)
          . header "X-Forwarded-For" "127.0.0.42"
      )
      <!! const 201 === statusCode
  let Just bob = userId <$> responseJsonMaybe rsp2
  -- ensure Alice and Bob are not connected
  void $ getConnection brig bob alice <!! const 404 === statusCode
  void $ getConnection brig alice bob <!! const 404 === statusCode
  -- Alice updates her profile
  let newColId = Just 5
      newAssets = Just [ImageAsset (AssetKeyV3 (Id (fromJust (UUID.fromString "5cd81cc4-c643-4e9c-849c-c596a88c27fd"))) AssetExpiring) (Just AssetComplete)]
      newName = Just $ Name "Alice in Wonderland"
      newPic = Nothing -- Legacy
      userUpdate = UserUpdate newName Nothing newPic newAssets newColId
      update = RequestBodyLBS . encode $ userUpdate
  -- Update profile & receive notification
  WS.bracketRN cannon [alice, bob] $ \[aliceWS, bobWS] -> do
    put (brig . path "/self" . contentJson . zUser alice . zConn "c" . body update)
      !!! const 200 === statusCode
    liftIO $ mapConcurrently_ (\ws -> assertUpdateNotification ws alice userUpdate) [aliceWS, bobWS]

testInvitationEmail :: Brig -> Http ()
testInvitationEmail brig = do
  (inviter, tid) <- createUserWithTeam brig
  invite <- stdInvitationRequest <$> randomEmail
  res <-
    postInvitation brig tid inviter invite <!! do
      const 201 === statusCode
  inv <- responseJsonError res
  let actualHeader = getHeader "Location" res
  let expectedHeader = "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId
  liftIO $ do
    Just inviter @=? inv.createdBy
    tid @=? inv.team
    assertInvitationResponseInvariants invite inv
    (isNothing . (.inviteeUrl)) inv @? "No invitation url expected"
    actualHeader @?= Just expectedHeader

assertInvitationResponseInvariants :: InvitationRequest -> Invitation -> Assertion
assertInvitationResponseInvariants invReq inv = do
  invReq.inviteeName @=? inv.inviteeName
  invReq.inviteeEmail @=? inv.inviteeEmail

testGetInvitation :: Brig -> Http ()
testGetInvitation brig = do
  (inviter, tid) <- createUserWithTeam brig
  invite <- stdInvitationRequest <$> randomEmail
  inv1 <- responseJsonError =<< postInvitation brig tid inviter invite <!! do const 201 === statusCode
  inv2 :: Invitation <- responseJsonError =<< getInvitation brig tid inv1.invitationId inviter <!! do const 200 === statusCode
  liftIO $ inv1 @=? inv2

testDeleteInvitation :: Brig -> Http ()
testDeleteInvitation brig = do
  (inviter, tid) <- createUserWithTeam brig
  invite <- stdInvitationRequest <$> randomEmail
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite <!! do const 201 === statusCode
  deleteInvitation brig tid inv.invitationId inviter
  getInvitation brig tid inv.invitationId inviter !!! do const 404 === statusCode

-- FUTUREWORK: This test should be rewritten to be free of mocks once Galley is
-- inlined into Brig.
testInvitationUrl :: Opt.Opts -> Brig -> Http ()
testInvitationUrl opts brig = do
  (inviter, tid) <- createUserWithTeam brig
  invite <- stdInvitationRequest <$> randomEmail

  void . withMockedGalley opts (invitationUrlGalleyMock FeatureStatusEnabled tid inviter) $ do
    resp <-
      postInvitation brig tid inviter invite
        <!! (const 201 === statusCode)

    inv :: Invitation <- responseJsonError resp
    invCode <- getInvitationCode brig tid inv.invitationId
    liftIO $ do
      assertInvitationResponseInvariants invite inv
      isJust invCode @? "Expect an invitation code in the backend"
      Just inviter @=? inv.createdBy
      tid @=? inv.team
      getQueryParam "team-code" resp @=? (invCode <&> (toStrict . toByteString))

getQueryParam :: ByteString -> ResponseLBS -> Maybe ByteString
getQueryParam name r = do
  inv :: Invitation <- (eitherToMaybe . responseJsonEither) r
  url <- inv.inviteeUrl
  (lookup name . queryPairs . uriQuery) url

-- | Mock the feature API because exposeInvitationURLsToTeamAdmin depends on
-- static configuration that cannot be changed at runtime.
invitationUrlGalleyMock ::
  FeatureStatus ->
  TeamId ->
  UserId ->
  ReceivedRequest ->
  MockT IO Wai.Response
invitationUrlGalleyMock featureStatus tid inviter (ReceivedRequest mth pth body_)
  | mth == "GET"
      && pth == ["i", "teams", Text.pack (show tid), "features", "exposeInvitationURLsToTeamAdmin"] =
      pure . Wai.responseLBS HTTP.status200 mempty $
        encode
          ( LockableFeature
              featureStatus
              LockStatusUnlocked
              ExposeInvitationURLsToTeamAdminConfig
          )
  | mth == "GET"
      && pth == ["i", "teams", Text.pack (show tid), "members", Text.pack (show inviter)] =
      pure . Wai.responseLBS HTTP.status200 mempty $
        encode (mkTeamMember inviter fullPermissions Nothing UserLegalHoldDisabled)
  | mth == "GET"
      && pth == ["i", "feature-configs"] =
      pure $ Wai.responseLBS HTTP.status200 mempty (encode (def @AllTeamFeatures))
  | otherwise =
      let errBody =
            encode . object $
              [ "msg" .= ("unexpecUnexpected request to mocked galley" :: Text),
                "method" .= show mth,
                "path" .= pth,
                "body" .= (cs @_ @Text body_)
              ]
       in pure $ Wai.responseLBS HTTP.status500 mempty errBody

-- FUTUREWORK: This test should be rewritten to be free of mocks once Galley is
-- inlined into Brig.
testNoInvitationUrl :: Opt.Opts -> Brig -> Http ()
testNoInvitationUrl opts brig = do
  (inviter, tid) <- createUserWithTeam brig
  invite <- stdInvitationRequest <$> randomEmail

  void . withMockedGalley opts (invitationUrlGalleyMock FeatureStatusDisabled tid inviter) $ do
    resp <-
      postInvitation brig tid inviter invite
        <!! (const 201 === statusCode)

    inv :: Invitation <- responseJsonError resp
    invCode <- getInvitationCode brig tid inv.invitationId
    liftIO $ do
      assertInvitationResponseInvariants invite inv
      isJust invCode @? "Expect an invitation code in the backend"
      Just inviter @=? inv.createdBy
      tid @=? inv.team
      (isNothing . (.inviteeUrl)) inv @? "No invitation url expected"

testInvitationEmailLookup :: Brig -> Http ()
testInvitationEmailLookup brig = do
  email <- randomEmail
  -- expect no invitation to be found for an email before that person is invited
  headInvitationByEmail brig email 404
  (uid, tid) <- createUserWithTeam brig
  let invite = stdInvitationRequest email
  void $ postInvitation brig tid uid invite
  -- expect an invitation to be found querying with email after invite
  headInvitationByEmail brig email 200
  (uid2, tid2) <- createUserWithTeam brig
  let invite2 = stdInvitationRequest email
  void $ postInvitation brig tid2 uid2 invite2
  -- expect a 409 conflict result for a second team inviting the same user
  headInvitationByEmail brig email 409

testInvitationEmailLookupRegister :: Brig -> Http ()
testInvitationEmailLookupRegister brig = do
  email <- randomEmail
  (owner, tid) <- createUserWithTeam brig
  let invite = stdInvitationRequest email
  -- This incidentally also tests that sending multiple
  -- invites from the same team results in last-invite-wins scenario
  void $ postInvitation brig tid owner invite
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite
  -- expect an invitation to be found querying with email after invite
  headInvitationByEmail brig email 200
  void $ registerInvite brig tid inv email
  -- expect a 404 after invitation has been used.
  headInvitationByEmail brig email 404

testInvitationEmailLookupNginz :: Brig -> Nginz -> Http ()
testInvitationEmailLookupNginz brig nginz = do
  email <- randomEmail
  -- expect no invitation to be found for an email before that person is invited
  headInvitationByEmail nginz email 404
  (uid, tid) <- createUserWithTeam brig
  let invite = stdInvitationRequest email
  void $ postInvitation brig tid uid invite
  -- expect an invitation to be found querying with email after invite
  headInvitationByEmail nginz email 200

headInvitationByEmail :: (Request -> Request) -> EmailAddress -> Int -> Http ()
headInvitationByEmail service email expectedCode =
  Bilge.head (service . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email))
    !!! const expectedCode === statusCode

testInvitationTooManyPending :: Opt.Opts -> Brig -> TeamSizeLimit -> Http ()
testInvitationTooManyPending opts brig (TeamSizeLimit limit) = do
  (inviter, tid) <- createUserWithTeam brig
  emails <- replicateConcurrently (fromIntegral limit) randomEmail
  email <- randomEmail
  -- If this test takes longer to run than `team-invitation-timeout`, then some of the
  -- invitations have likely expired already and this test will actually _fail_
  -- therefore we increase the timeout from default 10 to 300 seconds
  let longerTimeout = opts {Opt.settings = opts.settings {Opt.teamInvitationTimeout = 300}}
  withSettingsOverrides longerTimeout $ do
    forM_ emails $ postInvitation brig tid inviter . stdInvitationRequest
  postInvitation brig tid inviter (stdInvitationRequest email) !!! do
    const 403 === statusCode
    const (Just "too-many-team-invitations") === fmap Error.label . responseJsonMaybe

registerInvite :: Brig -> TeamId -> Invitation -> EmailAddress -> Http UserId
registerInvite brig tid inv invemail = do
  Just inviteeCode <- getInvitationCode brig tid inv.invitationId
  rsp <-
    post
      ( brig
          . path "/register"
          . contentJson
          . body (accept invemail inviteeCode)
          . header "X-Forwarded-For" "127.0.0.42"
      )
      <!! const 201 === statusCode
  let Just invitee = userId <$> responseJsonMaybe rsp
  pure invitee

-- | Admins can invite external partners, but not owners.
testInvitationRoles :: (HasCallStack) => Brig -> Galley -> Http ()
testInvitationRoles brig galley = do
  (owner, tid) <- createUserWithTeam brig
  -- owner creates a member alice.
  alice :: UserId <- do
    aliceEmail <- randomEmail
    let invite = stdInvitationRequest' Nothing (Just RoleAdmin) aliceEmail
    inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite
    registerInvite brig tid inv aliceEmail
  -- alice creates a external partner bob.  success!  bob only has externalPartner perms.
  do
    bobEmail <- randomEmail
    let invite = stdInvitationRequest' Nothing (Just RoleExternalPartner) bobEmail
    inv :: Invitation <-
      responseJsonError
        =<< ( postInvitation brig tid alice invite <!! do
                const 201 === statusCode
            )
    uid <- registerInvite brig tid inv bobEmail
    let memreq =
          galley
            . zUser owner
            . zConn "c"
            . paths ["teams", toByteString' tid, "members", toByteString' uid]
    mem :: TeamMember <- responseJsonError =<< (get memreq <!! const 200 === statusCode)
    liftIO $ assertEqual "perms" (rolePermissions RoleExternalPartner) (mem ^. permissions)
  -- alice creates an owner charly.  failure!
  do
    charlyEmail <- randomEmail
    let invite = stdInvitationRequest' Nothing (Just RoleOwner) charlyEmail
    postInvitation brig tid alice invite !!! do
      const 403 === statusCode
      const (Just "insufficient-permissions") === fmap Error.label . responseJsonMaybe

testInvitationEmailAccepted :: Brig -> Galley -> Http ()
testInvitationEmailAccepted brig galley = do
  email <- randomEmail
  let invite = stdInvitationRequest email
  (inviter, tid) <- createUserWithTeam brig
  let invitationHandshake ::
        forall m'.
        ( HasCallStack,
          MonadIO m',
          MonadHttp m',
          MonadCatch m',
          MonadFail m'
        ) =>
        m' (Maybe (UserId, UTCTimeMillis), UserId)
      invitationHandshake = do
        inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite
        let invmeta = Just (inviter, inv.createdAt)
        Just inviteeCode <- getInvitationCode brig tid inv.invitationId
        rsp2 <-
          post
            ( brig
                . path "/register"
                . contentJson
                . body (accept invite.inviteeEmail inviteeCode)
                . header "X-Forwarded-For" "127.0.0.42"
            )
            <!! const 201 === statusCode
        let Just (invitee, Just email2) = (userId &&& userEmail) <$> responseJsonMaybe rsp2
        let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2
        liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid)
        -- Verify that the invited user is active
        login brig (defEmailLogin email2) PersistentCookie !!! const 200 === statusCode
        pure (invmeta, invitee)
  (invmeta, invitee) <- invitationHandshake

  -- Verify that the user is part of the team
  mem <- getTeamMember invitee tid galley
  liftIO $ assertEqual "Member not part of the team" invitee (mem ^. Member.userId)
  liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Member.invitation)
  conns <-
    responseJsonError
      =<< listConnections brig invitee
        <!! const 200 === statusCode
  liftIO $ assertBool "User should have no connections" (null (clConnections conns) && not (clHasMore conns))

testCreateTeam :: Brig -> Galley -> UserJournalWatcher -> Http ()
testCreateTeam brig galley userJournalWatcher = do
  email <- randomEmail
  usr <- responseJsonError =<< register email newTeam brig
  let uid = userId usr
  let tid = fromMaybe (error "No team??") $ userTeam usr
  team <- Team.tdTeam <$> getTeam galley tid
  mem <- getTeamMember uid (team ^. teamId) galley
  liftIO $ assertBool "Member not part of the team" (uid == mem ^. Member.userId)
  -- Verify that the user cannot send invitations before activating their account
  inviteeEmail <- randomEmail
  let invite = stdInvitationRequest inviteeEmail
  postInvitation brig (team ^. teamId) uid invite !!! const 403 === statusCode
  -- Verify that the team is still in status "pending"
  team2 <- getTeam galley (team ^. teamId)
  liftIO $ assertEqual "status" Team.PendingActive (Team.tdStatus team2)
  -- Activate account
  act <- getActivationCode brig (Left email)
  case act of
    Nothing -> liftIO $ assertFailure "activation key/code not found"
    Just kc -> activate brig kc !!! const 200 === statusCode
  Util.assertUserActivateJournaled userJournalWatcher usr "user activate"
  -- Verify that Team has status Active now
  team3 <- getTeam galley (team ^. teamId)
  liftIO $ assertEqual "status" Team.Active (Team.tdStatus team3)

testCreateTeamPreverified :: Brig -> Galley -> UserJournalWatcher -> Http ()
testCreateTeamPreverified brig galley userJournalWatcher = do
  email <- randomEmail
  requestActivationCode brig 200 (Left email)
  act <- getActivationCode brig (Left email)
  case act of
    Nothing -> liftIO $ assertFailure "activation key/code not found"
    Just (_, c) -> do
      usr <- responseJsonError =<< register' email newTeam c brig <!! const 201 === statusCode
      let uid = userId usr
      Util.assertUserActivateJournaled userJournalWatcher usr "user activate"
      let tid = fromMaybe (error "No team??") $ userTeam usr
      team <- Team.tdTeam <$> getTeam galley tid
      mem <- getTeamMember uid (team ^. teamId) galley
      liftIO $ assertBool "Member not part of the team" (uid == mem ^. Member.userId)
      team2 <- getTeam galley (team ^. teamId)
      liftIO $ assertEqual "Team should already be active" Team.Active (Team.tdStatus team2)
      -- Verify that the user can already send invitations before activating their account
      inviteeEmail <- randomEmail
      let invite = stdInvitationRequest inviteeEmail
      postInvitation brig (team ^. teamId) uid invite !!! const 201 === statusCode

testInvitationNoPermission :: Brig -> Http ()
testInvitationNoPermission brig = do
  (_, tid) <- createUserWithTeam brig
  alice <- userId <$> randomUser brig
  email <- randomEmail
  let invite = stdInvitationRequest email
  postInvitation brig tid alice invite !!! do
    const 403 === statusCode
    const (Just "insufficient-permissions") === fmap Error.label . responseJsonMaybe

testTeamNoPassword :: Brig -> Http ()
testTeamNoPassword brig = do
  e <- randomEmail
  -- Team creators must have a password
  post
    ( brig
        . path "/register"
        . contentJson
        . body
          ( RequestBodyLBS . encode $
              object
                [ "name" .= ("Bob" :: Text),
                  "email" .= fromEmail e,
                  "team" .= newTeam
                ]
          )
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! const 400 === statusCode
  -- And so do any other binding team members
  code <- liftIO $ InvitationCode . Ascii.encodeBase64Url <$> randomBytes 24
  post
    ( brig
        . path "/register"
        . contentJson
        . body
          ( RequestBodyLBS . encode $
              object
                [ "name" .= ("Bob" :: Text),
                  "email" .= fromEmail e,
                  "team_code" .= code
                ]
          )
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! const 400 === statusCode

testInvitationCodeExists :: Brig -> Http ()
testInvitationCodeExists brig = do
  (uid, tid) <- createUserWithTeam brig
  let invite email = stdInvitationRequest email
  email <- randomEmail
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid (invite email) <!! const 201 === statusCode
  Just invCode <- getInvitationCode brig tid inv.invitationId
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email invCode)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! const 201 === statusCode
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email invCode)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 409 === statusCode
      const (Just "key-exists") === fmap Error.label . responseJsonMaybe
  email2 <- randomEmail
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email2 invCode)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 400 === statusCode
      const (Just "invalid-invitation-code") === fmap Error.label . responseJsonMaybe

testInvitationInvalidCode :: Brig -> Http ()
testInvitationInvalidCode brig = do
  email <- randomEmail
  -- Syntactically invalid
  let code1 = InvitationCode (Ascii.unsafeFromText "8z6JVcO1o4o¿9kFeb4Y3N-BmhIjH6b33")
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email code1)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 400 === statusCode
      const (Just "bad-request") === fmap Error.label . responseJsonMaybe
  -- Syntactically valid but semantically invalid
  code2 <- liftIO $ InvitationCode . Ascii.encodeBase64Url <$> randomBytes 24
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email code2)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 400 === statusCode
      const (Just "invalid-invitation-code") === fmap Error.label . responseJsonMaybe

testInvitationCodeNoIdentity :: Brig -> Http ()
testInvitationCodeNoIdentity brig = do
  uid <- liftIO $ Id <$> UUID.nextRandom
  post
    ( brig
        . path "/register"
        . contentJson
        . body (payload uid)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 403 === statusCode
      const (Just "missing-identity") === fmap Error.label . responseJsonMaybe
  where
    payload u =
      RequestBodyLBS . encode $
        object
          [ "name" .= ("Bob" :: Text),
            "team_code" .= u,
            "password" .= defPassword
          ]

testInvitationMutuallyExclusive :: Brig -> Http ()
testInvitationMutuallyExclusive brig = do
  email <- randomEmail
  code <- liftIO $ InvitationCode . Ascii.encodeBase64Url <$> randomBytes 24
  req email (Just code) (Just newTeam) Nothing !!! const 400 === statusCode
  req email (Just code) Nothing (Just code) !!! const 400 === statusCode
  req email Nothing (Just newTeam) (Just code) !!! const 400 === statusCode
  req email (Just code) (Just newTeam) (Just code) !!! const 400 === statusCode
  where
    req ::
      EmailAddress ->
      Maybe InvitationCode ->
      Maybe NewTeam ->
      Maybe InvitationCode ->
      HttpT IO (Response (Maybe LByteString))
    req e c t i =
      post
        ( brig
            . path "/register"
            . contentJson
            . body
              ( RequestBodyLBS . encode $
                  object
                    [ "name" .= ("Bob" :: Text),
                      "email" .= fromEmail e,
                      "password" .= defPassword,
                      "team_code" .= c,
                      "team" .= t,
                      "invitation_code" .= i
                    ]
              )
            . header "X-Forwarded-For" "127.0.0.42"
        )

testInvitationTooManyMembers :: Brig -> Galley -> TeamSizeLimit -> Http ()
testInvitationTooManyMembers brig galley (TeamSizeLimit limit) = do
  (creator, tid) <- createUserWithTeam brig
  pooledForConcurrentlyN_ 16 [1 .. limit - 1] $ \_ -> do
    void $ createTeamMember brig galley creator tid fullPermissions
  SearchUtil.refreshIndex brig
  let invite email = stdInvitationRequest email
  email <- randomEmail
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid creator (invite email)
  Just inviteeCode <- getInvitationCode brig tid inv.invitationId
  post
    ( brig
        . path "/register"
        . contentJson
        . body (accept email inviteeCode)
        . header "X-Forwarded-For" "127.0.0.42"
    )
    !!! do
      const 403 === statusCode
      const (Just "too-many-team-members") === fmap Error.label . responseJsonMaybe

testInvitationPaging :: (HasCallStack) => Opt.Opts -> Brig -> Http ()
testInvitationPaging opts brig = do
  before <- liftIO $ toUTCTimeMillis . addUTCTime (-1) <$> getCurrentTime
  (uid, tid) <- createUserWithTeam brig
  let total = 5
      invite email = stdInvitationRequest email
      longerTimeout = opts {Opt.settings = opts.settings {Opt.teamInvitationTimeout = 300}}
  emails <-
    withSettingsOverrides longerTimeout $
      replicateM total $ do
        email <- randomEmail
        postInvitation brig tid uid (invite email) !!! const 201 === statusCode
        pure email
  after1ms <- liftIO $ toUTCTimeMillis . addUTCTime 1 <$> getCurrentTime
  let getPages :: (HasCallStack) => Int -> Maybe InvitationId -> Int -> Http [[Invitation]]
      getPages count start step = do
        let range = queryRange (toByteString' <$> start) (Just step)
        r <-
          get (brig . paths ["teams", toByteString' tid, "invitations"] . zUser uid . range)
            <!! const 200
              === statusCode
        (invs, more) <- (ilInvitations &&& ilHasMore) <$> responseJsonError r
        if more
          then (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step
          else pure [invs]
  let checkSize :: (HasCallStack) => Int -> [Int] -> Http ()
      checkSize pageSize expectedSizes =
        getPages 0 Nothing pageSize >>= \invss -> liftIO $ do
          assertEqual "page sizes" expectedSizes (take (length expectedSizes) (map length invss))
          mapM_ validateInv $ concat invss
      validateInv :: Invitation -> Assertion
      validateInv inv = do
        assertEqual "tid" tid (inv.team)
        assertBool "email" (inv.inviteeEmail `elem` emails)
        -- (the output list is not ordered chronologically and emails are unique, so we just
        -- check whether the email is one of the valid ones.)
        assertBool "timestamp" (inv.createdAt > before && inv.createdAt < after1ms)
        assertEqual "uid" (Just uid) (inv.createdBy)
  -- not checked: @invitation inv :: InvitationId@

  checkSize 2 [2, 2, 1]
  checkSize total [total]
  checkSize (total + 1) [total]

testInvitationInfo :: Brig -> Http ()
testInvitationInfo brig = do
  email <- randomEmail
  (uid, tid) <- createUserWithTeam brig
  let invite = stdInvitationRequest email
  inv <- responseJsonError =<< postInvitation brig tid uid invite
  Just invCode <- getInvitationCode brig tid inv.invitationId
  Just invitation <- getInvitationInfo brig invCode
  liftIO $ assertEqual "Invitations differ" inv invitation

testInvitationInfoBadCode :: Brig -> Http ()
testInvitationInfoBadCode brig = do
  -- The code contains non-ASCII characters after url-decoding
  let icode = "8z6JVcO1o4o%C2%BF9kFeb4Y3N-BmhIjH6b33"
  get (brig . path ("/teams/invitations/info?code=" <> icode))
    !!! const 400 === statusCode

testInvitationInfoExpired :: Brig -> Timeout -> Http ()
testInvitationInfoExpired brig timeout = do
  email <- randomEmail
  (uid, tid) <- createUserWithTeam brig
  let invite = stdInvitationRequest email
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid invite
  -- Note: This value must be larger than the option passed as `team-invitation-timeout`
  awaitExpiry (round timeout + 5) tid inv.invitationId
  getCode tid inv.invitationId !!! const 400 === statusCode
  headInvitationByEmail brig email 404
  where
    getCode t i =
      get
        ( brig
            . path "/i/teams/invitation-code"
            . queryItem "team" (toByteString' t)
            . queryItem "invitation_id" (toByteString' i)
        )
    awaitExpiry :: Int -> TeamId -> InvitationId -> Http ()
    awaitExpiry n t i = do
      liftIO $ threadDelay 1000000
      r <- getCode t i
      when (statusCode r == 200 && n > 0) $
        awaitExpiry (n - 1) t i

testSuspendTeam :: Brig -> Http ()
testSuspendTeam brig = do
  inviteeEmail <- randomEmail
  inviteeEmail2 <- randomEmail
  (inviter, tid) <- createUserWithTeam brig
  -- invite and register invitee
  let invite = stdInvitationRequest inviteeEmail
  inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite
  Just inviteeCode <- getInvitationCode brig tid inv.invitationId
  rsp2 <-
    post
      ( brig
          . path "/register"
          . contentJson
          . body (accept inviteeEmail inviteeCode)
          . header "X-Forwarded-For" "127.0.0.42"
      )
      <!! const 201 === statusCode
  let Just (invitee, Just email) = (userId &&& userEmail) <$> responseJsonMaybe rsp2
  -- invite invitee2 (don't register)
  let invite2 = stdInvitationRequest inviteeEmail2

  inv2 :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite2
  Just _ <- getInvitationCode brig tid inv2.invitationId
  -- suspend team
  suspendTeam brig tid !!! const 200 === statusCode
  -- login fails
  login brig (defEmailLogin email) PersistentCookie !!! do
    const 403 === statusCode
    const (Just "suspended") === fmap Error.label . responseJsonMaybe
  -- check status
  chkStatus brig inviter Suspended
  chkStatus brig invitee Suspended
  assertNoInvitationCode brig tid inv2.invitationId
  -- unsuspend
  unsuspendTeam brig tid !!! const 200 === statusCode
  chkStatus brig inviter Active
  chkStatus brig invitee Active
  login brig (defEmailLogin email) PersistentCookie !!! const 200 === statusCode

testDeleteTeamUser :: Brig -> Galley -> Http ()
testDeleteTeamUser brig galley = do
  (creator, tid) <- createUserWithTeam brig
  -- Cannot delete the user since it will make the team orphan
  deleteUser creator (Just defPassword) brig !!! do
    const 403 === statusCode
    const (Just "no-self-delete-for-team-owner") === fmap Error.label . responseJsonMaybe
  -- We need to invite another user to a full permission member
  invitee <- userId <$> inviteAndRegisterUser creator tid brig
  updatePermissions creator tid (invitee, fullPermissions) galley
  -- Still cannot delete, must be demoted first
  deleteUser creator (Just defPassword) brig !!! do
    const 403 === statusCode
    const (Just "no-self-delete-for-team-owner") === fmap Error.label . responseJsonMaybe
  -- Demote creator
  updatePermissions invitee tid (creator, rolePermissions RoleAdmin) galley
  -- Now the creator can delete the account
  deleteUser creator (Just defPassword) brig !!! const 200 === statusCode
  -- The new full permission member cannot
  deleteUser invitee (Just defPassword) brig !!! const 403 === statusCode
  -- We can still invite new users who can delete their account only if they are not an owner
  inviteeFull <- userId <$> inviteAndRegisterUser invitee tid brig
  updatePermissions invitee tid (inviteeFull, fullPermissions) galley
  deleteUser inviteeFull (Just defPassword) brig !!! do
    const 403 === statusCode
    const (Just "no-self-delete-for-team-owner") === fmap Error.label . responseJsonMaybe
  inviteeMember <- userId <$> inviteAndRegisterUser invitee tid brig
  deleteUser inviteeMember (Just defPassword) brig !!! const 200 === statusCode
  -- still cannot delete invitee
  deleteUser invitee (Just defPassword) brig !!! do
    const 403 === statusCode
    const (Just "no-self-delete-for-team-owner") === fmap Error.label . responseJsonMaybe
  -- Ensure internal endpoints are also exercised
  deleteUserInternal invitee brig !!! const 202 === statusCode
  -- Eventually the user will be deleted, leaving the team orphan
  void $ retryWhileN 20 (/= Deleted) (getStatus brig invitee)
  chkStatus brig invitee Deleted

testSSOIsTeamOwner :: Brig -> Galley -> Http ()
testSSOIsTeamOwner brig galley = do
  (creator, tid) <- createUserWithTeam brig
  stranger <- userId <$> randomUser brig
  invitee <- userId <$> inviteAndRegisterUser creator tid brig
  let check expectWhat uid = void $ get (galley . paths opath . expectWhat)
        where
          opath = ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid]
  check expect2xx creator
  check expect4xx stranger
  check expect4xx invitee
  updatePermissions creator tid (invitee, fullPermissions) galley
  check expect2xx invitee

testConnectionSameTeam :: Brig -> Http ()
testConnectionSameTeam brig = do
  (creatorA, tidA) <- createUserWithTeam brig
  inviteeA <- userId <$> inviteAndRegisterUser creatorA tidA brig
  postConnection brig creatorA inviteeA !!! do
    const 403 === statusCode
    const (Just "same-binding-team-users") === fmap Error.label . responseJsonMaybe
  creatorB <- userId <$> randomUser brig
  -- Can connect across teams
  postConnection brig creatorA creatorB !!! const 201 === statusCode
  external <- userId <$> randomUser brig
  -- Externals are also ok
  postConnection brig creatorA external !!! const 201 === statusCode
  postConnection brig creatorB external !!! const 201 === statusCode

----------------------------------------------------------------------
-- SSO

testCreateUserInternalSSO :: Brig -> Galley -> Http ()
testCreateUserInternalSSO brig galley = do
  teamid <- snd <$> createUserWithTeam brig
  let ssoid = UserSSOId mkSimpleSampleUref
  -- creating users requires both sso_id and team_id
  postUser' True False "dummy" True False (Just ssoid) Nothing brig
    !!! const 400 === statusCode
  postUser' True False "dummy" True False Nothing (Just teamid) brig
    !!! const 400 === statusCode
  -- creating user with sso_id, team_id is ok
  resp <-
    postUser "dummy" True False (Just ssoid) (Just teamid) brig <!! do
      const 201 === statusCode
      const (Just ssoid) === (userSSOId . selfUser <=< responseJsonMaybe)
  -- self profile contains sso id
  let Just uid = userId <$> responseJsonMaybe resp
  profile <- getSelfProfile brig uid
  liftIO $
    assertEqual
      "self profile user identity mismatch"
      (Just ssoid)
      (userSSOId $ selfUser profile)
  -- sso-managed users must have team id.
  let Just teamid' = userTeam $ selfUser profile
  liftIO $ assertEqual "bad team_id" teamid teamid'
  -- does galley know about this?  is user active?
  _ <- getTeamMember uid teamid galley
  isact <- isActivatedUser uid brig
  liftIO $ assertBool "user not activated" isact

-- | See also: 'testDeleteTeamUser'.
testDeleteUserSSO :: Brig -> Galley -> Http ()
testDeleteUserSSO brig galley = do
  (creator, tid) <- createUserWithTeam brig
  let ssoid = UserSSOId mkSimpleSampleUref
      mkuser :: Bool -> Http (Maybe User)
      mkuser withemail =
        responseJsonMaybe
          <$> ( postUser "dummy" withemail False (Just ssoid) (Just tid) brig
                  <!! const 201 === statusCode
              )
  -- create and delete sso user (with email)
  Just (userId -> user1) <- mkuser True
  deleteUser user1 (Just defPassword) brig !!! const 200 === statusCode
  -- create sso user with email
  Just (userId -> creator') <- mkuser True
  updatePermissions creator tid (creator', fullPermissions) galley
  -- demote and delete creator, but cannot do it for second owner yet (as someone needs to demote them)
  updatePermissions creator' tid (creator, rolePermissions RoleMember) galley
  deleteUser creator (Just defPassword) brig !!! const 200 === statusCode
  -- create sso user without email, make an owner
  Just (userId -> user3) <- mkuser False
  updatePermissions creator' tid (user3, fullPermissions) galley
  -- can't delete herself, even without email
  deleteUser user3 (Just defPassword) brig !!! const 403 === statusCode
  -- delete second owner now, we don't enforce existence of emails in the backend
  updatePermissions user3 tid (creator', rolePermissions RoleMember) galley
  deleteUser creator' (Just defPassword) brig !!! const 200 === statusCode

test2FaDisabledForSsoUser :: Brig -> Galley -> Http ()
test2FaDisabledForSsoUser brig galley = do
  teamid <- snd <$> createUserWithTeam brig
  setTeamFeatureLockStatus @Public.SndFactorPasswordChallengeConfig galley teamid Public.LockStatusUnlocked
  setTeamSndFactorPasswordChallenge galley teamid Public.FeatureStatusEnabled
  let ssoid = UserSSOId mkSimpleSampleUref
  createUserResp <-
    postUser "dummy" True False (Just ssoid) (Just teamid) brig <!! do
      const 201 === statusCode
      const (Just ssoid) === (userSSOId . selfUser <=< responseJsonMaybe)
  let Just uid = userId <$> responseJsonMaybe createUserResp
  let verificationCode = Nothing
  addClient brig uid (defNewClientWithVerificationCode verificationCode PermanentClientType [head somePrekeys] (head someLastPrekeys))
    !!! const 201 === statusCode

-- TODO:
-- add sso service.  (we'll need a name for that now.)
-- brig needs to notify the sso service about deletions!
-- if the mock sso service disagrees with the deletion: 403 "sso-not-allowed" or something
-- if user is last remaining owner: 403 "no-other-owner" (as above).
-- otherwise: 2xx.
