{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- 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.MockInterpreters.UserStore where

import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Handle
import Data.Id
import Data.Map qualified as Map
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.State
import Wire.API.Password
import Wire.API.User hiding (DeleteUser)
import Wire.API.User qualified as User
import Wire.API.User.Search (SetSearchable (SetSearchable))
import Wire.StoredUser
import Wire.UserStore
import Wire.UserStore.IndexUser

runInMemoryUserStoreInterpreter :: [StoredUser] -> Map UserId Password -> InterpreterFor UserStore r
runInMemoryUserStoreInterpreter users passwords =
  evalState users
    . evalState passwords
    . inMemoryUserStoreInterpreter
    . raiseUnder
    . raiseUnder

inMemoryUserStoreInterpreter ::
  forall r.
  ( Member (State [StoredUser]) r,
    Member (State (Map UserId Password)) r
  ) =>
  InterpreterFor UserStore r
inMemoryUserStoreInterpreter = inMemoryUserStoreInterpreterWithDeleteHook (const $ pure ())

inMemoryUserStoreInterpreterWithDeleteHook ::
  forall r.
  ( Member (State [StoredUser]) r,
    Member (State (Map UserId Password)) r
  ) =>
  (UserId -> Sem r ()) ->
  InterpreterFor UserStore r
inMemoryUserStoreInterpreterWithDeleteHook onDelete = interpret $ \case
  CreateUser new _ -> do
    modify (newStoredUserToStoredUser new :)
    forM_ new.password $ modify . Map.insert new.id
  GetUsers uids -> do
    gets $ filter (\user -> user.id `elem` uids)
  DoesUserExist uid -> gets @[StoredUser] (any (\u -> u.id == uid))
  UpdateUser uid update -> modify (map doUpdate)
    where
      doUpdate :: StoredUser -> StoredUser
      doUpdate u =
        if u.id == uid
          then
            maybe Imports.id setStoredUserAccentId update.accentId
              . maybe Imports.id setStoredUserAssets update.assets
              . maybe Imports.id setStoredUserPict update.pict
              . maybe Imports.id setStoredUserName update.name
              . maybe Imports.id setStoredUserLocale update.locale
              . maybe Imports.id setStoredUserSupportedProtocols update.supportedProtocols
              $ u
          else u
  UpdateEmail uid email -> modify (map doUpdate)
    where
      doUpdate :: StoredUser -> StoredUser
      doUpdate u =
        if u.id == uid
          then u {email = Just email} :: StoredUser
          else u
  UpdateEmailUnvalidated uid email -> modify (map doUpdate)
    where
      doUpdate :: StoredUser -> StoredUser
      doUpdate u =
        if u.id == uid
          then u {emailUnvalidated = Just email} :: StoredUser
          else u
  DeleteEmailUnvalidated uid -> modify (map doUpdate)
    where
      doUpdate :: StoredUser -> StoredUser
      doUpdate u =
        if u.id == uid
          then u {emailUnvalidated = Nothing} :: StoredUser
          else u
  UpdateSSOId uid ssoId -> do
    updateUserInStore uid (\u -> u {ssoId = ssoId})
    gets @[StoredUser] (any (\u -> u.id == uid))
  UpdateManagedBy uid managedBy -> updateUserInStore uid (\u -> u {managedBy = Just managedBy})
  UpdateAccountStatus uid accountStatus -> updateUserInStore uid (\u -> u {status = Just accountStatus})
  ActivateUser uid identity -> updateUserInStore uid (\u -> u {activated = True, email = emailIdentity identity})
  DeactivateUser uid -> updateUserInStore uid (\u -> u {activated = False})
  UpdateFeatureConferenceCalling {} -> error "UpdateFeatureConferenceCalling: Not implemented"
  LookupFeatureConferenceCalling {} -> error "FeatureConferenceCalling: Not implemented"
  GetIndexUser uid -> do
    mUser <- gets @[StoredUser] $ find (\user -> user.id == uid)
    pure $ storedUserToIndexUser <$> mUser
  GetIndexUsersPaginated _pageSize _pagingState ->
    error "GetIndexUsersPaginated not implemented in inMemoryUserStoreInterpreter"
  UpdateUserHandleEither uid hUpdate -> runError $ modifyLocalUsers (traverse doUpdate)
    where
      doUpdate :: StoredUser -> Sem (Error StoredUserUpdateError : r) StoredUser
      doUpdate u
        | u.id == uid = do
            handles <- gets @[StoredUser] $ mapMaybe (.handle)
            when
              ( hUpdate.old
                  /= Just hUpdate.new
                  && elem hUpdate.new handles
              )
              $ throw StoredUserUpdateHandleExists
            pure $ setStoredUserHandle hUpdate.new u
      doUpdate u = pure u

      modifyLocalUsers :: forall r1. (Member (State [StoredUser]) r1) => ([StoredUser] -> Sem r1 [StoredUser]) -> Sem r1 ()
      modifyLocalUsers f = do
        us <- get
        us' <- f us
        put us'
  DeleteUser user -> do
    onDelete (User.userId user)
    modify @[StoredUser] $ filter (\u -> u.id /= User.userId user)
  LookupName uid -> (.name) <$$> gets @[StoredUser] (find $ \u -> u.id == uid)
  LookupHandle h -> lookupHandleImpl h
  GlimpseHandle h -> lookupHandleImpl h
  LookupStatus uid -> lookupStatusImpl uid
  IsActivated uid -> isActivatedImpl uid
  LookupLocale uid -> lookupLocaleImpl uid
  UpdateUserTeam uid tid ->
    modify $
      map
        (\u -> if u.id == uid then u {teamId = Just tid} :: StoredUser else u)
  GetRichInfo _ -> error "GetRichInfo: not implemented"
  UpdateRichInfo {} -> error "UpdateRichInfo: Not implemented"
  UpsertHashedPassword uid pw ->
    modify $ Map.insert uid pw
  LookupHashedPassword uid ->
    gets $ Map.lookup uid
  GetUserAuthenticationInfo uid -> runMaybeT $ do
    status <- MaybeT $ lookupStatusImpl uid
    pw <- lift $ gets @(Map UserId Password) $ Map.lookup uid
    pure (pw, status)
  DeleteEmail uid -> modify (map doUpdate)
    where
      doUpdate :: StoredUser -> StoredUser
      doUpdate u = if u.id == uid then u {email = Nothing} else u
  GetUserTeam uid -> do
    gets @[StoredUser] $ \users -> do
      user <- find (\user -> user.id == uid) users
      user.teamId
  SetUserSearchable uid (SetSearchable searchable) -> modify $ map f
    where
      f u =
        if u.id == uid
          then u {Wire.StoredUser.searchable = Just searchable} :: StoredUser
          else u
  DeleteServiceUser {} -> error "DeleteServiceUser: Not implemented"
  LookupServiceUsers {} -> error "lookupServiceUsers: Not implemented"
  LookupServiceUsersForTeam {} -> error "lookupServiceUsersForteam: Not implemented"

storedUserToIndexUser :: StoredUser -> IndexUser
storedUserToIndexUser storedUser =
  -- If we really care about this, we could start storing the writetimes, but we
  -- don't need it right now
  let defaultTime = UTCTime (YearDay 0 1) 0
   in IndexUser
        { userId = storedUser.id,
          userType = inferUserType storedUser.serviceId storedUser.userType,
          teamId = storedUser.teamId,
          name = storedUser.name,
          accountStatus = storedUser.status,
          handle = storedUser.handle,
          email = storedUser.email,
          colourId = storedUser.accentId,
          activated = storedUser.activated,
          serviceId = storedUser.serviceId,
          managedBy = storedUser.managedBy,
          ssoId = storedUser.ssoId,
          unverifiedEmail = Nothing,
          searchable = storedUser.searchable,
          createdAt = defaultTime,
          updatedAt = defaultTime
        }

lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country)))
lookupLocaleImpl uid = do
  users <- get
  let mUser = find ((== uid) . (.id)) users
  pure $ (\u -> (u.language, u.country)) <$> mUser

isActivatedImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r Bool
isActivatedImpl uid = do
  gets $
    maybe False (.activated)
      . find ((== uid) . (.id))

lookupStatusImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe AccountStatus)
lookupStatusImpl uid = do
  users <- get
  pure $ (.status) =<< (find ((== uid) . (.id)) users)

lookupHandleImpl ::
  (Member (State [StoredUser]) r) =>
  Handle ->
  Sem r (Maybe UserId)
lookupHandleImpl h = do
  gets $
    fmap (.id)
      . find ((== Just h) . (.handle))

updateUserInStore :: (Member (State [StoredUser]) r) => UserId -> (StoredUser -> StoredUser) -> Sem r ()
updateUserInStore uid f = modify (map doUpdate)
  where
    doUpdate :: StoredUser -> StoredUser
    doUpdate u =
      if u.id == uid
        then f u
        else u
