{-# OPTIONS_GHC -Wno-ambiguous-fields -Wno-incomplete-uni-patterns -Wno-incomplete-patterns #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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 Wire.UserGroupSubsystem.InterpreterSpec where

import Control.Error.Util (hush)
import Control.Lens ((.~), (^.))
import Control.Monad
import Data.Aeson qualified as A
import Data.Bifunctor (first)
import Data.Default
import Data.Domain (Domain (Domain))
import Data.Id
import Data.Json.Util
import Data.List.Extra
import Data.Map qualified as Map
import Data.Qualified
import Data.Range
import Data.Set qualified as Set
import Data.Tagged (Tagged)
import Data.UUID qualified as UUID
import Data.Vector qualified as V
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input (Input, runInputConst)
import Polysemy.Internal.Kind
import Polysemy.State
import System.Random qualified as Rand
import System.Timeout (timeout)
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Wire.API.Error (ErrorS)
import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound))
import Wire.API.Pagination
import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll), Route (RouteAny))
import Wire.API.Team.Member as TM
import Wire.API.Team.Role
import Wire.API.User as User
import Wire.API.UserEvent
import Wire.API.UserGroup
import Wire.API.UserGroup.Pagination
import Wire.Arbitrary
import Wire.BackgroundJobsPublisher qualified as BackgroundJobsPublisher
import Wire.GalleyAPIAccess
import Wire.MockInterpreters as Mock
import Wire.NotificationSubsystem
import Wire.Sem.Random qualified as Random
import Wire.Sem.Random.Null qualified as Random
import Wire.StoredUser
import Wire.TeamSubsystem
import Wire.TeamSubsystem.GalleyAPI
import Wire.UserGroupSubsystem
import Wire.UserGroupSubsystem.Interpreter (UserGroupSubsystemError (..), interpretUserGroupSubsystem)
import Wire.UserSubsystem

type AllDependencies =
  '[ UserSubsystem,
     TeamSubsystem,
     GalleyAPIAccess
   ]
    `Append` UserGroupStoreInMemEffectStack
    `Append` '[ Input (Local ()),
                MockNow,
                NotificationSubsystem,
                BackgroundJobsPublisher.BackgroundJobPublisher,
                State [Push],
                Random.Random,
                Error UserGroupSubsystemError,
                ErrorS 'TeamMemberNotFound,
                ErrorS 'TeamNotFound
              ]

runDependenciesFailOnError ::
  (HasCallStack) =>
  [StoredUser] ->
  Map TeamId [TeamMember] ->
  Sem AllDependencies (IO ()) ->
  IO ()
runDependenciesFailOnError usrs team =
  either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team

runDependencies ::
  [StoredUser] ->
  Map TeamId [TeamMember] ->
  Sem AllDependencies a ->
  Either LocalErrors a
runDependencies initialUsers initialTeams =
  run . runLocalErrors . interpretDependencies initialUsers initialTeams

interpretDependencies ::
  forall r a.
  [StoredUser] ->
  Map TeamId [TeamMember] ->
  Sem (AllDependencies `Append` r) a ->
  Sem ('[Error UserGroupSubsystemError, ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound] `Append` r) a
interpretDependencies initialUsers initialTeams =
  Random.randomToNull
    . evalState mempty
    . noopBackgroundJobPublisher
    . inMemoryNotificationSubsystemInterpreter
    . evalState defaultTime
    . runInputConst (toLocalUnsafe (Domain "example.com") ())
    . runInMemoryUserGroupStore def
    . miniGalleyAPIAccess initialTeams def
    . interpretTeamSubsystemToGalleyAPI
    . runInMemoryUserSubsytemInterpreter initialUsers mempty

runDependenciesWithReturnState ::
  [StoredUser] ->
  Map TeamId [TeamMember] ->
  Sem AllDependencies a ->
  Either LocalErrors ([Push], a)
runDependenciesWithReturnState initialUsers initialTeams =
  run
    . runLocalErrors
    . Random.randomToNull
    . runState mempty
    . noopBackgroundJobPublisher
    . inMemoryNotificationSubsystemInterpreter
    . evalState defaultTime
    . runInputConst (toLocalUnsafe (Domain "example.com") ())
    . runInMemoryUserGroupStore def
    . miniGalleyAPIAccess initialTeams def
    . interpretTeamSubsystemToGalleyAPI
    . runInMemoryUserSubsytemInterpreter initialUsers mempty

data LocalErrors
  = ETeamMemberNotFound
  | ETeamNotFound
  | ESubsystem UserGroupSubsystemError
  deriving stock (Eq, Show)

runLocalErrors ::
  Sem (Error UserGroupSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a ->
  Sem r (Either LocalErrors a)
runLocalErrors = fmap toLocalErrors . runError . runError . runError
  where
    toLocalErrors ::
      Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either UserGroupSubsystemError a)) ->
      Either LocalErrors a
    toLocalErrors = \case
      Right (Right (Right a)) -> Right a
      Right (Right (Left e)) -> Left (ESubsystem e)
      Right (Left _) -> Left ETeamMemberNotFound
      Left _ -> Left ETeamNotFound

expectRight :: (Show err) => Either err Property -> Property
expectRight = \case
  Left err -> counterexample ("Unexpected error: " <> show err) False
  Right p -> p

expectLeft :: (Show err, Eq err) => err -> Either err Property -> Property
expectLeft expectedErr = \case
  Left err -> err === expectedErr
  Right _ -> counterexample ("Expected error, but it didn't happen") False

unexpected :: Sem r Property
unexpected =
  pure $ counterexample "An error was expected to have occurred by now" False

-- | This makes even hspec/quickcheck properties terminate, but at the cost of eliminating
-- shrinking (the timeout is running inside the test runs for each generated input).
timeoutHook :: Spec -> Spec
timeoutHook =
  describe "[timeout wrapper]"
    . around_ (maybe (fail "exceeded timeout") pure <=< timeout 1_000_000)
    . modifyMaxShrinks (const 0)

spec :: Spec
spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do
  describe "CreateGroup :: UserId -> NewUserGroup -> UserGroupSubsystem m UserGroup" $ do
    prop "team admins should be able to create and get groups" $ \team newUserGroupName seed ->
      let rndShuffle xs gen = map fst $ sortOn snd $ zip xs (Rand.randoms gen :: [Int])
          -- ~half the users
          n = length (allUsers team) `div` 2 + 1
          members = take n $ rndShuffle (allUsers team) (Rand.mkStdGen seed)
          resultOrError =
            runDependenciesWithReturnState (allUsers team) (galleyTeam team)
              . interpretUserGroupSubsystem
              $ do
                let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList members} :: NewUserGroup
                createdGroup <- createGroup (ownerId team) newUserGroup'
                retrievedGroup <- getGroup (ownerId team) createdGroup.id_ False
                now <- toUTCTimeMillis <$> get
                let assert =
                      createdGroup.name === newUserGroupName
                        .&&. createdGroup.members === Identity (newUserGroup').members
                        .&&. createdGroup.managedBy === ManagedByWire
                        .&&. createdGroup.createdAt === now
                        .&&. Just createdGroup === retrievedGroup
                pure (createdGroup, assert)

          assertPushEvents :: UserGroup -> [Push] -> Property
          assertPushEvents ug pushes =
            foldl
              ( \acc push ->
                  acc .&&. case A.fromJSON @Event (A.Object push.json) of
                    A.Success (UserGroupEvent (UserGroupCreated ugid)) ->
                      ugid === ug.id_
                        .&&. push.origin === Just (ownerId team)
                    _ -> counterexample ("Failed to decode push: " <> show push) False
              )
              (length pushes === 1)
              pushes
       in case resultOrError of
            Left err -> counterexample ("Unexpected error: " <> show err) False
            Right (pushes, (ug, propertyCheck)) -> assertPushEvents ug pushes .&&. propertyCheck

    prop "only team admins and owners should get a group created notification" $ \team name (tm :: TeamMember) role ->
      let extraTeamMember = tm & permissions .~ rolePermissions role
          resultOrError =
            runDependenciesWithReturnState (allUsers team) (galleyTeamWithExtra team [extraTeamMember])
              . interpretUserGroupSubsystem
              $ createGroup (ownerId team) (newUserGroup name)

          expectedRecipient = Recipient (tm ^. TM.userId) RecipientClientsAll

          assertPushEvents :: UserGroup -> [Push] -> Property
          assertPushEvents ug pushes =
            foldl
              ( \acc push ->
                  acc .&&. case A.fromJSON @Event (A.Object push.json) of
                    A.Success (UserGroupEvent (UserGroupCreated ugid)) ->
                      push.origin === Just (ownerId team)
                        .&&. push.transient === True
                        .&&. push.route === RouteAny
                        .&&. push.nativePriority === Nothing
                        .&&. push.isCellsEvent === False
                        .&&. push.conn === Nothing
                        .&&. ugid === ug.id_
                        .&&. ( case role of
                                 RoleAdmin -> (expectedRecipient `elem` push.recipients) === True
                                 RoleOwner -> (expectedRecipient `elem` push.recipients) === True
                                 RoleMember -> (expectedRecipient `elem` push.recipients) === False
                                 RoleExternalPartner -> (expectedRecipient `elem` push.recipients) === False
                             )
                    _ -> counterexample ("Failed to decode push: " <> show push) False
              )
              (length pushes === 1)
              pushes
       in case resultOrError of
            Left err -> counterexample ("Unexpected error: " <> show err) False
            Right (pushes, ug) -> assertPushEvents ug pushes

    prop "only team admins should be able to create a group" $
      \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName ->
        expectLeft (ESubsystem UserGroupNotATeamAdmin)
          . runDependencies (allUsers team) (galleyTeam team)
          . interpretUserGroupSubsystem
          $ do
            let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList (allUsers team)} :: NewUserGroup
                [nonAdminUser] = someAdminsOrOwners 1 team
            void $ createGroup (nonAdminUser.id) newUserGroup'
            unexpected

    prop "only team members are allowed in the group" $ \team otherUsers newUserGroupName ->
      let othersWithoutTeamMembers = filter (\u -> u.teamId /= Just team.tid) otherUsers
       in notNull othersWithoutTeamMembers
            ==> expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam)
              . runDependencies (allUsers team <> otherUsers) (galleyTeam team)
              . interpretUserGroupSubsystem
            $ do
              let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList otherUsers} :: NewUserGroup
              void $ createGroup (ownerId team) newUserGroup'
              unexpected

  describe "GetGroup, GetGroups" $ do
    prop "key misses produce 404" $ \team groupId ->
      expectRight
        . runDependencies (allUsers team) (galleyTeam team)
        . interpretUserGroupSubsystem
        $ do
          mGroup <- getGroup (ownerId team) groupId False
          pure $ mGroup === Nothing

    prop "team admins can get all groups in their team; outsiders can see nothing" $ \team otherTeam userGroupName ->
      expectRight
        . runDependencies (allUsers team) (galleyTeam team)
        . interpretUserGroupSubsystem
        $ do
          group1 <- createGroup (ownerId team) (newUserGroup userGroupName)

          getGroupAdmin <- getGroup (ownerId team) group1.id_ False
          getGroupOutsider <- getGroup (ownerId otherTeam) group1.id_ False

          getGroupsAdmin <-
            getGroups
              (ownerId team)
              def
                { searchString = Just (userGroupNameToText userGroupName)
                }
          getGroupsOutsider <-
            try $
              getGroups
                (ownerId otherTeam)
                def
                  { searchString = Just (userGroupNameToText userGroupName)
                  }
          pure $
            getGroupAdmin === Just group1
              .&&. getGroupsAdmin.page === [userGroupToMeta group1]
              .&&. getGroupOutsider === Nothing
              .&&. getGroupsOutsider === Left UserGroupNotATeamAdmin

    prop "team members can only get user groups from their own team" $
      \(WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam)
       (WithMods team2 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) ->
          expectRight
            . runDependencies (allUsers team1 <> allUsers team2) (galleyTeam team1 <> galleyTeam team2)
            . interpretUserGroupSubsystem
            $ do
              let userGroupName1 = fromJust . hush $ userGroupNameFromText "first"
              let userGroupName2 = fromJust . hush $ userGroupNameFromText "second"

              group1 <- createGroup (ownerId team1) (newUserGroup userGroupName1)
              group2 <- createGroup (ownerId team2) (newUserGroup userGroupName2)

              getOwnGroup <- getGroup (ownerId team1) group1.id_ False
              getOtherGroup <- getGroup (ownerId team1) group2.id_ False
              getOwnGroups <-
                getGroups
                  (ownerId team1)
                  def
                    { searchString = Just (userGroupNameToText userGroupName1)
                    }
              getOtherGroups <-
                getGroups
                  (ownerId team1)
                  def
                    { searchString = Just (userGroupNameToText userGroupName2)
                    }

              pure $
                getOwnGroup === Just group1
                  .&&. getOwnGroups.page === [userGroupToMeta group1]
                  .&&. getOtherGroup === Nothing
                  .&&. getOtherGroups.page === []

    it "getGroups: q=<name>, returning 0, 1, 2 groups" $ do
      WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam <- generate arbitrary
      runDependenciesFailOnError (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do
        let newGroups = [newUserGroup (either undefined Imports.id $ userGroupNameFromText name) | name <- ["1", "2", "2", "33"]]
        groups <- (\ng -> passTime 1 >> createGroup (ownerId team1) ng) `mapM` newGroups

        get0 <- getGroups (ownerId team1) def {searchString = Just "nope"}
        get1 <- getGroups (ownerId team1) def {searchString = Just "1"}
        get2 <- getGroups (ownerId team1) def {searchString = Just "2"}
        get3 <- getGroups (ownerId team1) def {searchString = Just "3"}

        pure do
          get0.page `shouldBe` []
          get1.page `shouldBe` userGroupToMeta <$> [head groups]
          get2.page `shouldBe` userGroupToMeta <$> [groups !! 2, groups !! 1]
          get3.page `shouldBe` userGroupToMeta <$> [groups !! 3]

    prop "getGroups: pagination (happy flow)" $ do
      \(WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam)
       (Positive (Small (numGroups :: Int)))
       (Positive (Small (pageSizeFromIntegralTotal @Int -> pageSize))) ->
          expectRight
            . runDependencies (allUsers team1) (galleyTeam team1)
            . interpretUserGroupSubsystem
            $ do
              let mkNewGroup = newUserGroup (either undefined Imports.id $ userGroupNameFromText "same name")
                  mkGroup = passTime 1 >> createGroup (ownerId team1) mkNewGroup

              -- groups are only distinguished by creation date
              groups <- replicateM numGroups mkGroup

              results :: [UserGroupPage] <- do
                let fetch mLastThing = do
                      p <-
                        getGroups
                          (ownerId team1)
                          def
                            { paginationState = PaginationSortByCreatedAt $ (,) <$> fmap (fromUTCTimeMillis . (.createdAt)) mLastThing <*> fmap (.id_) mLastThing,
                              pageSize
                            }
                      if null p.page
                        then pure []
                        else
                          if length p.page < pageSizeToInt pageSize
                            then pure [p]
                            else (p :) <$> fetch (Just (last p.page))
                fetch Nothing

              let all' :: (x -> Property) -> [x] -> Property
                  all' mkProp = foldr (\x acc -> mkProp x .&&. acc) (True === True)

                  assertLessThanOrEq :: (Show a, Ord a) => a -> a -> Property
                  assertLessThanOrEq x y = counterexample (show x <> "\n>\n" <> show y) $ x <= y
              pure $
                Right pageSize === pageSizeFromInt 0
                  .||. (
                         -- result is complete and correct (`reverse` because `createdAt` defaults to `Desc`)
                         mconcat ((.page) <$> results) === (userGroupToMeta <$> reverse groups)
                           -- every page has the expected size
                           .&&. all'
                             (\r -> length r.page === pageSizeToInt pageSize)
                             (take (length results - 2) results)
                           .&&. all'
                             (\r -> length r.page `assertLessThanOrEq` pageSizeToInt pageSize)
                             (drop (length results - 2) results)
                       )

    prop "getGroups: pagination via offset" $ \(WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) ->
      runDependenciesFailOnError (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do
        -- Create groups
        groups <- forM ["1", "2", "3", "4", "5"] $ \name -> do
          passTime 1
          createGroup (ownerId team1) $ newUserGroup $ UserGroupName $ unsafeRange name
        let groupIds = map (.id_) groups :: [UserGroupId]

        -- Define helper to fetch all pages, providing desired
        -- sortOrder and page size to the mock database
        let getAllPages :: (Member UserGroupSubsystem r) => SortOrder -> Word -> Sem r [UserGroupPage]
            getAllPages sortOrder' pageSize' = go 0
              where
                go :: (Member UserGroupSubsystem r) => Word -> Sem r [UserGroupPage]
                go offset = do
                  p <-
                    getGroups
                      (ownerId team1)
                      def
                        { paginationState = PaginationOffset offset,
                          pageSize = PageSize $ unsafeRange $ fromIntegral pageSize',
                          sortOrder = sortOrder'
                        }
                  let len = length p.page
                  if
                    | len > 0 && len < fromIntegral pageSize' -> pure [p]
                    | len == 0 -> pure []
                    | otherwise -> (p :) <$> go (offset + pageSize')

        ascendingPages :: [UserGroupPage] <- getAllPages Asc 2
        descendingPages :: [UserGroupPage] <- getAllPages Desc 3
        exactlyOnePage :: [UserGroupPage] <- getAllPages Desc 5

        pure do
          -- Page sizes are as expected
          map (length . (.page)) ascendingPages `shouldBe` [2, 2, 1]
          map (length . (.page)) descendingPages `shouldBe` [3, 2]
          map (length . (.page)) exactlyOnePage `shouldBe` [5]

          -- Sort order is accounted for, pages do not overlap
          (map (.id_) . (.page) =<< ascendingPages) `shouldBe` sort groupIds
          (map (.id_) . (.page) =<< descendingPages) `shouldBe` sortBy (comparing Down) groupIds

    it "getGroups (ordering)" $ do
      WithMods team1 :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam <- generate arbitrary
      runDependenciesFailOnError (allUsers team1) (galleyTeam team1) . interpretUserGroupSubsystem $ do
        let mkGroup name = createGroup (ownerId team1) (newUserGroup $ either undefined Imports.id $ userGroupNameFromText name)

        -- construct groups such that there are groups with same name and different creation
        -- date and vice versa.  create names in random order (not alpha).  the digits are
        -- group names, `a` and `b` are times.
        group2a <- mkGroup "2"
        group1a <- mkGroup "1"
        group3a <- mkGroup "3"
        passTime 1
        group2b <- mkGroup "2"
        group1b <- mkGroup "1"
        group3b <- mkGroup "3"

        sortByDefaults <- getGroups (ownerId team1) def
        sortByNameDesc <-
          getGroups
            (ownerId team1)
            def
              { paginationState = PaginationSortByName Nothing,
                sortOrder = Desc
              }
        sortByCreatedAtAsc <-
          getGroups
            (ownerId team1)
            def
              { paginationState = PaginationSortByCreatedAt Nothing,
                sortOrder = Asc
              }

        let expectSortByDefaults = [[group1b, group2b, group3b], [group1a, group2a, group3a]]
            expectSortByNameDesc = [[group3a, group3b], [group2a, group2b], [group1a, group1b]]
            expectSortByCreatedAtAsc = [[group1a, group2a, group3a], [group1b, group2b, group3b]]

            -- for every list in first argument (expected), take the corresponding number of elements
            -- from the second (actual), and compare them as sets.
            validatePartialOrder :: [[UserGroupId]] -> [UserGroupId] -> Bool
            validatePartialOrder = f
              where
                f [] [] = True
                f [] (_ : _) = False
                f (_ : _) [] = False
                f (xs : expect') rest@(_ : _) = case splitAt (length xs) rest of
                  (xs', rest') -> Set.fromList xs == Set.fromList xs' && f expect' rest'

        pure do
          ((.id_) <$> sortByDefaults.page) `shouldSatisfy` validatePartialOrder ((.id_) <$$> expectSortByDefaults)
          ((.id_) <$> sortByNameDesc.page) `shouldSatisfy` validatePartialOrder ((.id_) <$$> expectSortByNameDesc)
          ((.id_) <$> sortByCreatedAtAsc.page) `shouldSatisfy` validatePartialOrder ((.id_) <$$> expectSortByCreatedAtAsc)

  describe "UpdateGroup :: UserId -> UserGroupId -> UserGroupUpdate -> UserGroupSubsystem m (Maybe UserGroup)" $ do
    prop "updateGroup updates the name" $
      \(team :: ArbitraryTeam) (originalName :: UserGroupName) (userGroupUpdate :: UserGroupUpdate) ->
        expectRight
          . runDependencies (allUsers team) (galleyTeam team)
          . interpretUserGroupSubsystem
          $ do
            ug0 :: UserGroup <- createGroup (ownerId team) (newUserGroup originalName)
            ug1 :: Maybe UserGroup <- getGroup (ownerId team) ug0.id_ False
            updateGroup (ownerId team) ug0.id_ userGroupUpdate
            ug2 :: Maybe UserGroup <- getGroup (ownerId team) ug0.id_ False
            pure $
              (ug1 === Just ug0)
                .&&. (ug2 === Just (ug0 {name = userGroupUpdate.name} :: UserGroup))

    prop "update sends events to all admins and owners" $ \team name newName (tm :: TeamMember) role ->
      let extraTeamMember = tm & permissions .~ rolePermissions role
          resultOrError =
            runDependenciesWithReturnState (allUsers team) (galleyTeamWithExtra team [extraTeamMember])
              . interpretUserGroupSubsystem
              $ do
                ug <- createGroup (ownerId team) (newUserGroup name)
                updateGroup (ownerId team) ug.id_ (UserGroupUpdate (UserGroupName newName))
                pure ug

          expectedRecipient = Recipient (tm ^. TM.userId) RecipientClientsAll

          assertPushEvents :: UserGroup -> [Push] -> Property
          assertPushEvents ug [push, _createEvent] = case A.fromJSON @Event (A.Object push.json) of
            A.Success (UserGroupEvent (UserGroupUpdated ugid)) ->
              push.origin === Just (ownerId team)
                .&&. push.transient === True
                .&&. push.route === RouteAny
                .&&. push.nativePriority === Nothing
                .&&. push.isCellsEvent === False
                .&&. push.conn === Nothing
                .&&. ugid === ug.id_
                .&&. ( case role of
                         RoleAdmin -> (expectedRecipient `elem` push.recipients) === True
                         RoleOwner -> (expectedRecipient `elem` push.recipients) === True
                         RoleMember -> (expectedRecipient `elem` push.recipients) === False
                         RoleExternalPartner -> (expectedRecipient `elem` push.recipients) === False
                     )
            _ -> counterexample ("Failed to decode push: " <> show push) False
       in case resultOrError of
            Left err -> counterexample ("Unexpected error: " <> show err) False
            Right (pushes, ug) -> assertPushEvents ug pushes

    prop "only team admins should be able to update a group" $
      \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName newUserGroupName2 ->
        expectLeft (ESubsystem UserGroupNotATeamAdmin)
          . runDependencies (allUsers team) (galleyTeam team)
          . interpretUserGroupSubsystem
          $ do
            let newUserGroup' = (newUserGroup newUserGroupName) {members = (.id) <$> V.fromList (allUsers team)} :: NewUserGroup
                [nonAdminUser] = someAdminsOrOwners 1 team
            grp <- createGroup (ownerId team) newUserGroup'
            void $ updateGroup nonAdminUser.id grp.id_ (UserGroupUpdate newUserGroupName2)
            unexpected

  describe "DeleteGroup :: UserId -> UserGroupId -> UserGroupSubsystem m ()" $ do
    prop "deleteGroup deletes" $ \team name name2 team2 -> do
      expectRight
        . runDependencies (allUsers team <> allUsers team2) (galleyTeam team <> galleyTeam team2)
        . interpretUserGroupSubsystem
        $ do
          ug <- createGroup (ownerId team) (newUserGroup name)
          ug2 <- createGroup (ownerId team) (newUserGroup name2)

          mUg <- getGroup (ownerId team) ug.id_ False
          isDeleted <- isNothing <$> (deleteGroup (ownerId team) ug.id_ >> getGroup (ownerId team) ug.id_ False)
          mUg2 <- getGroup (ownerId team) ug2.id_ False
          e1 <- catchExpectedError $ deleteGroup (ownerId team2) ug.id_
          e2 <- catchExpectedError $ deleteGroup (ownerId team) (Id UUID.nil)

          pure $
            mUg === Just ug
              .&&. isDeleted === True
              .&&. mUg2 === Just ug2
              .&&. e1 === Just UserGroupNotFound
              .&&. e2 === Just UserGroupNotFound

    prop "delete sends events to all admins and owners" $ \team name (tm :: TeamMember) role ->
      let extraTeamMember = tm & permissions .~ rolePermissions role
          resultOrError =
            runDependenciesWithReturnState (allUsers team) (galleyTeamWithExtra team [extraTeamMember])
              . interpretUserGroupSubsystem
              $ do
                let nug = newUserGroup name
                ug <- createGroup (ownerId team) nug
                deleteGroup (ownerId team) ug.id_
                pure ug

          expectedRecipient = Recipient (tm ^. TM.userId) RecipientClientsAll

          assertPushEvents :: UserGroup -> [Push] -> Property
          assertPushEvents ug [push, _createEvent] = case A.fromJSON @Event (A.Object push.json) of
            A.Success (UserGroupEvent (UserGroupDeleted ugid)) ->
              push.origin === Just (ownerId team)
                .&&. push.transient === True
                .&&. push.route === RouteAny
                .&&. push.nativePriority === Nothing
                .&&. push.isCellsEvent === False
                .&&. push.conn === Nothing
                .&&. ugid === ug.id_
                .&&. ( case role of
                         RoleAdmin -> (expectedRecipient `elem` push.recipients) === True
                         RoleOwner -> (expectedRecipient `elem` push.recipients) === True
                         RoleMember -> (expectedRecipient `elem` push.recipients) === False
                         RoleExternalPartner -> (expectedRecipient `elem` push.recipients) === False
                     )
            _ -> counterexample ("Failed to decode push: " <> show push) False
       in case resultOrError of
            Left err -> counterexample ("Unexpected error: " <> show err) False
            Right (pushes, ug) -> assertPushEvents ug pushes

    prop "only team admins can delete user groups" $
      \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) groupName ->
        expectLeft (ESubsystem UserGroupNotATeamAdmin)
          . runDependencies (allUsers team) (galleyTeam team)
          . interpretUserGroupSubsystem
          $ do
            grp <- createGroup (ownerId team) (newUserGroup groupName)
            let [nonAdminUser] = someAdminsOrOwners 1 team
            void $ deleteGroup nonAdminUser.id grp.id_
            unexpected

  describe "AddUser, RemoveUser :: UserId -> UserGroupId -> UserId -> UserGroupSubsystem m ()" $ do
    prop "addUser, removeUser adds, removes a user" $
      \((WithMods team) :: WithMods '[AtLeastSixMembers] ArbitraryTeam) newGroupName ->
        let [mbr1, mbr2] = someMembersWithRoles 2 team Nothing
            resultOrError =
              runDependenciesWithReturnState (allUsers team) (galleyTeam team)
                . interpretUserGroupSubsystem
                $ do
                  ug :: UserGroup <- createGroup (ownerId team) (newUserGroup newGroupName)

                  addUser (ownerId team) ug.id_ mbr1.id
                  ugWithFirst <- getGroup (ownerId team) ug.id_ False

                  addUser (ownerId team) ug.id_ mbr1.id
                  ugWithIdemP <- getGroup (ownerId team) ug.id_ False

                  addUser (ownerId team) ug.id_ mbr2.id
                  ugWithSecond <- getGroup (ownerId team) ug.id_ False

                  removeUser (ownerId team) ug.id_ mbr1.id
                  ugWithoutFirst <- getGroup (ownerId team) ug.id_ False
                  removeUser (ownerId team) ug.id_ mbr1.id -- idemp
                  let propertyCheck =
                        ((.members) <$> ugWithFirst) === Just (Identity $ V.fromList [mbr1.id])
                          .&&. ((.members) <$> ugWithIdemP) === Just (Identity $ V.fromList [mbr1.id])
                          .&&. ((sort . V.toList . runIdentity . (.members)) <$> ugWithSecond) === Just (sort [mbr1.id, mbr2.id])
                          .&&. ((.members) <$> ugWithoutFirst) === Just (Identity $ V.fromList [mbr2.id])
                  pure (ug, propertyCheck)

            assertUpdateEvent :: UserGroup -> Push -> Property
            assertUpdateEvent ug push = case A.fromJSON @Event (A.Object push.json) of
              A.Success (UserGroupEvent (UserGroupUpdated ugid)) ->
                push.origin === Just (ownerId team)
                  .&&. ugid === ug.id_
                  .&&. Set.fromList push.recipients
                    === Set.fromList [Recipient {recipientUserId = user.id, recipientClients = RecipientClientsAll} | user <- allAdmins team]
              _ -> counterexample ("Failed to decode push: " <> show push) False
         in case resultOrError of
              Left err -> counterexample ("Unexpected error: " <> show err) False
              Right ([update3, update2, update1, _create], (ug, propertyCheck)) ->
                propertyCheck
                  .&&. assertUpdateEvent ug update1
                  .&&. assertUpdateEvent ug update2
                  .&&. assertUpdateEvent ug update3

    prop "added/removed user must be team member." $
      \((WithMods team) :: WithMods '[AtLeastSixMembers] ArbitraryTeam)
       newGroupName
       (team2 :: ArbitraryTeam)
       (addOrRemove :: Bool) ->
          expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam)
            . runDependencies (allUsers team) (galleyTeam team)
            . interpretUserGroupSubsystem
            $ do
              ug <- createGroup (ownerId team) (newUserGroup newGroupName)
              (if addOrRemove then addUser else removeUser) (ownerId team) ug.id_ (ownerId team2)
              unexpected

    prop "adding/removing user must be team admin." $
      \((WithMods team) :: WithMods '[AtLeastSixMembers] ArbitraryTeam)
       newGroupName
       (team2 :: ArbitraryTeam)
       (addOrRemove :: Bool) ->
          expectLeft (ESubsystem UserGroupNotFound)
            . runDependencies (allUsers team) (galleyTeam team)
            . interpretUserGroupSubsystem
            $ do
              ug <- createGroup (ownerId team) (newUserGroup newGroupName)
              (if addOrRemove then addUser else removeUser) (ownerId team2) ug.id_ (ownerId team)
              unexpected

data TeamGenMod = AtLeastOneMember | AtLeastSixMembers | AtLeastOneNonAdmin

class KnownTeamGenMod a where
  teamGenMod :: TeamGenMod

instance KnownTeamGenMod 'AtLeastOneMember where
  teamGenMod = AtLeastOneMember

instance KnownTeamGenMod 'AtLeastSixMembers where
  teamGenMod = AtLeastSixMembers

instance KnownTeamGenMod 'AtLeastOneNonAdmin where
  teamGenMod = AtLeastOneNonAdmin

applyConstraint :: forall mod. (KnownTeamGenMod mod) => Gen ArbitraryTeam -> Gen ArbitraryTeam
applyConstraint =
  case teamGenMod @mod of
    AtLeastOneMember -> flip suchThat \team ->
      not $ Imports.null team.members
    AtLeastSixMembers -> flip suchThat \team ->
      length team.members > 6
    AtLeastOneNonAdmin -> flip suchThat \team ->
      any (\(_, mem) -> not $ isAdminOrOwner (mem ^. permissions)) team.members

newtype WithMods (mods :: [TeamGenMod]) a = WithMods a
  deriving (Show, Eq)

class ArbitraryWithMods mods a where
  arbitraryWithMods :: Gen a

instance (Arbitrary a) => ArbitraryWithMods '[] a where
  arbitraryWithMods = arbitrary

instance (KnownTeamGenMod mod, ArbitraryWithMods mods ArbitraryTeam) => ArbitraryWithMods (mod ': mods) ArbitraryTeam where
  arbitraryWithMods =
    applyConstraint @mod $ arbitraryWithMods @mods

instance (ArbitraryWithMods mods a) => Arbitrary (WithMods mods a) where
  arbitrary = WithMods <$> arbitraryWithMods @mods
  shrink _ =
    -- you can write down a better implementation, but make sure the constraints are still
    -- satisfied by the shrunk output.
    []

data ArbitraryTeam = ArbitraryTeam
  { tid :: TeamId,
    owner :: (StoredUser, TeamMember),
    members :: [(StoredUser, TeamMember)]
  }
  deriving (Show, Eq)

instance Arbitrary ArbitraryTeam where
  arbitrary = do
    tid <- arbitrary
    let assignTeam u = u {teamId = Just tid} :: StoredUser
    adminUser <- assignTeam <$> arbitrary
    adminMember <-
      arbitrary @TeamMember
        <&> (permissions .~ rolePermissions RoleOwner)
        <&> (TM.userId .~ adminUser.id)
    otherUsers <- listOf' arbitrary
    otherUserWithMembers <- for otherUsers $ \u -> do
      mem <- arbitrary
      pure (u, mem & TM.userId .~ u.id)
    pure . ArbitraryTeam tid (adminUser, adminMember) $ map (first assignTeam) otherUserWithMembers

  shrink team =
    if null team.members
      then []
      else
        let lessMembers = take (length team.members `div` 2) team.members
         in [team {members = lessMembers}]

allUsers :: ArbitraryTeam -> [StoredUser]
allUsers t = fst <$> t.owner : t.members

ownerId :: ArbitraryTeam -> UserId
ownerId t = (fst t.owner).id

allAdmins :: ArbitraryTeam -> [StoredUser]
allAdmins t = fst <$> filter (isAdminOrOwner . (^. permissions) . snd) (t.owner : t.members)

-- | The Map is required by the mock GalleyAPIAccess
galleyTeam :: ArbitraryTeam -> Map TeamId [TeamMember]
galleyTeam t = galleyTeamWithExtra t []

galleyTeamWithExtra :: ArbitraryTeam -> [TeamMember] -> Map TeamId [TeamMember]
galleyTeamWithExtra t tm = Map.singleton t.tid $ tm <> map snd (t.owner : t.members)

someAdminsOrOwners :: Int -> ArbitraryTeam -> [StoredUser]
someAdminsOrOwners num team = someMembersWithRoles num team (Just [RoleMember, RoleExternalPartner])

someMembersWithRoles :: (HasCallStack) => Int -> ArbitraryTeam -> Maybe [Role] -> [StoredUser]
someMembersWithRoles num team mbRoles = result
  where
    result =
      if length found == num
        then found
        else error $ "not enough members in the team?  " <> show (num, mbRoles, memberPerms)

    memberPerms :: [Maybe Role]
    memberPerms = (permissionsRole . (^. TM.permissions) . snd) <$> team.members

    found = fst <$> take num (filter f team.members)
      where
        f (_, mem) = case mbRoles of
          Just roles -> permissionsRole (mem ^. permissions) `elem` (Just <$> roles)
          Nothing -> True

newUserGroup :: UserGroupName -> NewUserGroup
newUserGroup name = NewUserGroup {name = name, members = mempty}
