{-# LANGUAGE RecordWildCards #-}

-- 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.UserSearch.Types where

import Cassandra qualified as C
import Cassandra.Util
import Data.Aeson
import Data.Attoparsec.ByteString
import Data.ByteString.Builder
import Data.ByteString.Conversion
import Data.ByteString.Lazy
import Data.Handle
import Data.Id
import Data.Json.Util
import Data.Qualified
import Data.Text.Encoding
import Database.Bloodhound.Types
import Imports
import Test.QuickCheck
import Wire.API.Team.Feature
import Wire.API.Team.Role
import Wire.API.User
import Wire.API.User.Search
import Wire.Arbitrary
import Wire.StoredUser

newtype IndexVersion = IndexVersion {docVersion :: DocVersion}

mkIndexVersion :: [Maybe (Writetime x)] -> IndexVersion
mkIndexVersion writetimes =
  let maxVersion = getMax . mconcat . fmap (Max . writetimeToInt64) $ catMaybes writetimes
   in -- This minBound case would only get triggered when the maxVersion is <= 0
      -- or >= 9.2e+18. First case can happen when the writetimes list is empty
      -- or contains a timestamp before the unix epoch, which is unlikely.
      -- Second case will happen in a few billion years. It is also not really a
      -- restriction in ES, Bloodhound's authors' interpretation of the the ES
      -- documentation caused this limiation, otherwise `maxBound :: Int64`,
      -- would be acceptable by ES.
      IndexVersion . fromMaybe minBound . mkDocVersion . fromIntegral $ maxVersion

-- | Represents an ES *document*, ie. the subset of user attributes stored in ES.
-- See also 'IndexUser'.
--
-- If a user is not searchable, e.g. because the account got
-- suspended, all fields except for the user id are set to 'Nothing' and
-- consequently removed from the index.
data UserDoc = UserDoc
  { udId :: UserId,
    udType :: Maybe UserType,
    udTeam :: Maybe TeamId,
    udName :: Maybe Name,
    udNormalized :: Maybe Text,
    udHandle :: Maybe Handle,
    udEmail :: Maybe EmailAddress,
    udColourId :: Maybe ColourId,
    udAccountStatus :: Maybe AccountStatus,
    udSAMLIdP :: Maybe Text,
    udManagedBy :: Maybe ManagedBy,
    udCreatedAt :: Maybe UTCTimeMillis,
    udRole :: Maybe Role,
    udSearchVisibilityInbound :: Maybe SearchVisibilityInbound,
    udScimExternalId :: Maybe Text,
    udSso :: Maybe Sso,
    udEmailUnvalidated :: Maybe EmailAddress,
    udSearchable :: Maybe Bool
  }
  deriving (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform UserDoc)

instance ToJSON UserDoc where
  toJSON ud =
    object
      [ "id" .= udId ud,
        "type" .= udType ud,
        "team" .= udTeam ud,
        "name" .= udName ud,
        "normalized" .= udNormalized ud,
        "handle" .= udHandle ud,
        "email" .= udEmail ud,
        "accent_id" .= udColourId ud,
        "account_status" .= udAccountStatus ud,
        "saml_idp" .= udSAMLIdP ud,
        "managed_by" .= udManagedBy ud,
        "created_at" .= udCreatedAt ud,
        "role" .= udRole ud,
        searchVisibilityInboundFieldName .= udSearchVisibilityInbound ud,
        "scim_external_id" .= udScimExternalId ud,
        "sso" .= udSso ud,
        "email_unvalidated" .= udEmailUnvalidated ud,
        "searchable" .= udSearchable ud
      ]

instance FromJSON UserDoc where
  parseJSON = withObject "UserDoc" $ \o ->
    UserDoc
      <$> o .: "id"
      <*> o .:? "type"
      <*> o .:? "team"
      <*> o .:? "name"
      <*> o .:? "normalized"
      <*> o .:? "handle"
      <*> o .:? "email"
      <*> o .:? "accent_id"
      <*> o .:? "account_status"
      <*> o .:? "saml_idp"
      <*> o .:? "managed_by"
      <*> o .:? "created_at"
      <*> o .:? "role"
      <*> o .:? searchVisibilityInboundFieldName
      <*> o .:? "scim_external_id"
      <*> o .:? "sso"
      <*> o .:? "email_unvalidated"
      <*> o .:? "searchable"

searchVisibilityInboundFieldName :: Key
searchVisibilityInboundFieldName = "search_visibility_inbound"

-- Qualified UserId is not included in `UserDoc`, so it needs to be
-- provided here.  Monad will most likely be Identity (I promise we'll
-- always make up some name if missing) or Maybe (if no name, then no
-- contact).
userDocToContact :: (Monad m) => Qualified UserId -> (Maybe Name -> m Text) -> UserDoc -> m Contact
userDocToContact contactQualifiedId getName userDoc =
  getName userDoc.udName <&> \name ->
    Contact
      { contactQualifiedId,
        contactName = name,
        contactColorId = fromIntegral . fromColourId <$> userDoc.udColourId,
        contactHandle = fromHandle <$> userDoc.udHandle,
        contactTeam = userDoc.udTeam,
        contactType =
          -- users of type `UserTypeBot` are not searchable as
          -- contacts, so we can assume this is either
          -- `UserTypeRegular` or `UserTypeApp`.
          inferUserType Nothing userDoc.udType
      }

userDocToTeamContact :: [UserGroupId] -> UserDoc -> TeamContact
userDocToTeamContact userGroups UserDoc {..} =
  TeamContact
    { teamContactUserId = udId,
      teamContactUserType =
        -- bots are not searchable as contacts, so we can assume this is not one.
        inferUserType Nothing udType,
      teamContactTeam = udTeam,
      teamContactSso = udSso,
      teamContactScimExternalId = udScimExternalId,
      teamContactSAMLIdp = udSAMLIdP,
      teamContactRole = udRole,
      teamContactName = maybe "" fromName udName,
      teamContactManagedBy = udManagedBy,
      teamContactHandle = fromHandle <$> udHandle,
      teamContactEmailUnvalidated = udEmailUnvalidated,
      teamContactEmail = udEmail,
      teamContactCreatedAt = udCreatedAt,
      teamContactColorId = fromIntegral . fromColourId <$> udColourId,
      teamContactUserGroups = userGroups,
      teamContactSearchable = fromMaybe True udSearchable
    }

-- | Outbound search restrictions configured by team admin of the searcher. This
-- value restricts the set of user that are searched.
--
-- See 'optionallySearchWithinTeam' for the effect on full-text search.
--
-- See 'mkTeamSearchInfo' for the business logic that defines the TeamSearchInfo
-- value.
--
-- Search results might be affected by the inbound search restriction settings of
-- the searched user. ('SearchVisibilityInbound')
data TeamSearchInfo
  = -- | Only users that are not part of any team are searched
    NoTeam
  | -- | Only users from the same team as the searcher are searched
    TeamOnly TeamId
  | -- | No search restrictions, all users are searched
    AllUsers

-- | Inbound search restrictions configured by team to-be-searched. Affects only
-- full-text search (i.e. search on the display name and the handle), not exact
-- handle search.
data SearchVisibilityInbound
  = -- | The user can only be found by users from the same team
    SearchableByOwnTeam
  | -- | The user can by found by any user of any team
    SearchableByAllTeams
  deriving (Eq, Show)

instance Arbitrary SearchVisibilityInbound where
  arbitrary = elements [SearchableByOwnTeam, SearchableByAllTeams]

instance ToByteString SearchVisibilityInbound where
  builder SearchableByOwnTeam = "searchable-by-own-team"
  builder SearchableByAllTeams = "searchable-by-all-teams"

instance FromByteString SearchVisibilityInbound where
  parser =
    SearchableByOwnTeam
      <$ string "searchable-by-own-team"
        <|> SearchableByAllTeams
      <$ string "searchable-by-all-teams"

instance C.Cql SearchVisibilityInbound where
  ctype = C.Tagged C.IntColumn

  toCql SearchableByOwnTeam = C.CqlInt 0
  toCql SearchableByAllTeams = C.CqlInt 1

  fromCql (C.CqlInt 0) = pure SearchableByOwnTeam
  fromCql (C.CqlInt 1) = pure SearchableByAllTeams
  fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n

defaultSearchVisibilityInbound :: SearchVisibilityInbound
defaultSearchVisibilityInbound = SearchableByOwnTeam

searchVisibilityInboundFromFeatureStatus :: FeatureStatus -> SearchVisibilityInbound
searchVisibilityInboundFromFeatureStatus FeatureStatusDisabled = SearchableByOwnTeam
searchVisibilityInboundFromFeatureStatus FeatureStatusEnabled = SearchableByAllTeams

instance ToJSON SearchVisibilityInbound where
  toJSON = String . decodeUtf8 . toStrict . toLazyByteString . builder

instance FromJSON SearchVisibilityInbound where
  parseJSON = withText "SearchVisibilityInbound" $ \str ->
    case runParser (parser @SearchVisibilityInbound) (encodeUtf8 str) of
      Left err -> fail err
      Right result -> pure result

data IndexQuery r = IndexQuery Query Filter [DefaultSort]

data BrowseTeamFilters = BrowseTeamFilters
  { teamId :: TeamId,
    mQuery :: Maybe Text,
    mRoleFilter :: Maybe RoleFilter,
    mSortBy :: Maybe TeamUserSearchSortBy,
    mSortOrder :: Maybe TeamUserSearchSortOrder,
    mEmailVerificationFilter :: Maybe EmailVerificationFilter,
    mSearchable :: Maybe Bool
  }
  deriving (Eq, Show)

userIdToDocId :: UserId -> DocId
userIdToDocId uid = DocId (idToText uid)

-- | We use cassandra writetimes to construct the ES index version. Since nulling fields in
-- cassandra also nulls the writetime, re-indexing does not happen when nulling a field, and
-- the old search key can still effectively be used.
--
-- `write_time_bumper type int` is an extra field that we can update whenever we null a field
-- and want to update the write time of the table.  `WriteTimeBumper` writes to 'int' fields,
-- but only cares about the field's writetime.
data WriteTimeBumper = WriteTimeBumper
  deriving (Eq, Show)

instance C.Cql WriteTimeBumper where
  ctype = C.Tagged C.IntColumn
  toCql WriteTimeBumper = C.CqlInt 0
  fromCql _ = pure WriteTimeBumper
