{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData #-}

-- 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 Wire.API.User.Search
  ( SearchResult (..),
    Contact (..),
    TeamContact (..),
    RoleFilter (..),
    Sso (..),
    TeamUserSearchSortOrder (..),
    TeamUserSearchSortBy (..),
    FederatedUserSearchPolicy (..),
    PagingState (..),
    EmailVerificationFilter (..),
    SetSearchable (..),
    UserTypeFilter (..),
    userTypeFilterToText,
    userTypeFilterToUserType,
  )
where

import Cassandra qualified as C
import Control.Error
import Control.Lens ((?~))
import Data.Aeson hiding (object, (.=))
import Data.Aeson qualified as A
import Data.Aeson qualified as Aeson
import Data.Attoparsec.ByteString qualified as AP
import Data.Attoparsec.ByteString.Char8 (string)
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Conversion as BS
import Data.Id (TeamId, UserGroupId, UserId)
import Data.Json.Util (UTCTimeMillis)
import Data.OpenApi (ToParamSchema (..))
import Data.OpenApi qualified as S
import Data.Proxy
import Data.Qualified
import Data.Schema
import Data.Text qualified as T
import Data.Text.Ascii (AsciiBase64Url, toText, validateBase64Url)
import Data.Text.Encoding qualified as TE
import Imports
import Servant.API (FromHttpApiData, ToHttpApiData (..))
import Web.Internal.HttpApiData (parseQueryParam)
import Wire.API.Team.Role (Role)
import Wire.API.User (ManagedBy, UserType (..))
import Wire.API.User.Identity (EmailAddress)
import Wire.Arbitrary (Arbitrary, GenericUniform (..))

-------------------------------------------------------------------------------
-- PagingState

newtype PagingState = PagingState {unPagingState :: AsciiBase64Url}
  deriving newtype (Eq, Show, Arbitrary)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema PagingState

instance ToSchema PagingState where
  schema = (toText . unPagingState) .= parsedText "PagingState" (fmap PagingState . validateBase64Url)

instance ToParamSchema PagingState where
  toParamSchema _ = toParamSchema (Proxy @Text)

instance FromHttpApiData PagingState where
  parseQueryParam s = mapLeft T.pack $ PagingState <$> validateBase64Url s

instance ToHttpApiData PagingState where
  toQueryParam = toText . unPagingState

instance ToByteString PagingState where
  builder = builder . unPagingState

instance FromByteString PagingState where
  parser = fmap PagingState parser

--------------------------------------------------------------------------------
-- SearchResult

data SearchResult a = SearchResult
  { searchFound :: Int,
    searchReturned :: Int,
    searchTook :: Int,
    searchResults :: [a],
    searchPolicy :: FederatedUserSearchPolicy,
    searchPagingState :: Maybe PagingState,
    searchHasMore :: Maybe Bool
  }
  deriving stock (Eq, Show, Generic, Functor)
  deriving (Arbitrary) via (GenericUniform (SearchResult a))

instance Foldable SearchResult where
  foldMap f r = foldMap f (searchResults r)

instance Traversable SearchResult where
  traverse f r = do
    newResults <- traverse f (searchResults r)
    pure $ r {searchResults = newResults}

instance (ToSchema a, Typeable a) => ToSchema (SearchResult a) where
  schema =
    object $
      SearchResult
        <$> searchFound .= fieldWithDocModifier "found" (S.description ?~ "Total number of hits") schema
        <*> searchReturned .= fieldWithDocModifier "returned" (S.description ?~ "Total number of hits returned") schema
        <*> searchTook .= fieldWithDocModifier "took" (S.description ?~ "Search time in ms") schema
        <*> searchResults .= fieldWithDocModifier "documents" (S.description ?~ "List of contacts found") (array schema)
        <*> searchPolicy .= fieldWithDocModifier "search_policy" (S.description ?~ "Search policy that was applied when searching for users") schema
        <*> searchPagingState .= maybe_ (optFieldWithDocModifier "paging_state" (S.description ?~ "Paging state that should be supplied to retrieve the next page of results") schema)
        <*> searchHasMore .= maybe_ (optFieldWithDocModifier "has_more" (S.description ?~ "Indicates whether there are more results to be fetched") schema)

deriving via (Schema (SearchResult Contact)) instance ToJSON (SearchResult Contact)

deriving via (Schema (SearchResult TeamContact)) instance ToJSON (SearchResult TeamContact)

deriving via (Schema (SearchResult Contact)) instance FromJSON (SearchResult Contact)

deriving via (Schema (SearchResult TeamContact)) instance FromJSON (SearchResult TeamContact)

deriving via (Schema (SearchResult Contact)) instance S.ToSchema (SearchResult Contact)

deriving via (Schema (SearchResult TeamContact)) instance S.ToSchema (SearchResult TeamContact)

--------------------------------------------------------------------------------
-- Contact

-- | Returned by 'searchIndex' under @/search/contacts@.
-- This is a subset of 'User' and json instances should reflect that.
data Contact = Contact
  { contactQualifiedId :: Qualified UserId,
    contactName :: Text,
    contactColorId :: Maybe Int,
    contactHandle :: Maybe Text,
    contactTeam :: Maybe TeamId,
    contactType :: UserType
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform Contact)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema Contact

instance ToSchema Contact where
  schema =
    objectWithDocModifier (description ?~ "Contact discovered through search") $
      Contact
        <$> contactQualifiedId .= field "qualified_id" schema
        <* (qUnqualified . contactQualifiedId) .= optField "id" schema
        <*> contactName .= field "name" schema
        <*> contactColorId .= optField "accent_id" (maybeWithDefault Aeson.Null schema)
        <*> contactHandle .= optField "handle" (maybeWithDefault Aeson.Null schema)
        <*> contactTeam .= optField "team" (maybeWithDefault Aeson.Null schema)
        <*> contactType .= field "type" schema

--------------------------------------------------------------------------------
-- TeamContact

-- | Related to `UserSSOId`, but more straight-forward because it does not take SCIM externalId into account.
data Sso = Sso
  { ssoIssuer :: Text,
    ssoNameId :: Text
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform Sso)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Sso)

instance ToSchema Sso where
  schema =
    object $
      Sso
        <$> ssoIssuer .= field "issuer" schema
        <*> ssoNameId .= field "nameid" schema

-- | Returned by 'browseTeam' under @/teams/:tid/search@.
data TeamContact = TeamContact
  { teamContactUserId :: UserId,
    teamContactUserType :: UserType,
    teamContactName :: Text,
    teamContactColorId :: Maybe Int,
    teamContactHandle :: Maybe Text,
    teamContactTeam :: Maybe TeamId,
    teamContactEmail :: Maybe EmailAddress,
    teamContactCreatedAt :: Maybe UTCTimeMillis,
    teamContactManagedBy :: Maybe ManagedBy,
    teamContactSAMLIdp :: Maybe Text,
    teamContactRole :: Maybe Role,
    teamContactScimExternalId :: Maybe Text,
    teamContactSso :: Maybe Sso,
    teamContactEmailUnvalidated :: Maybe EmailAddress,
    teamContactUserGroups :: [UserGroupId],
    teamContactSearchable :: Bool
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform TeamContact)
  deriving (ToJSON, FromJSON) via (Schema TeamContact)

instance ToSchema TeamContact where
  schema =
    object $
      TeamContact
        <$> teamContactUserId .= field "id" schema
        <*> teamContactUserType .= field "type" schema
        <*> teamContactName .= field "name" schema
        <*> teamContactColorId .= optField "accent_id" (maybeWithDefault Aeson.Null schema)
        <*> teamContactHandle .= optField "handle" (maybeWithDefault Aeson.Null schema)
        <*> teamContactTeam .= optField "team" (maybeWithDefault Aeson.Null schema)
        <*> teamContactEmail .= optField "email" (maybeWithDefault Aeson.Null schema)
        <*> teamContactCreatedAt .= optField "created_at" (maybeWithDefault Aeson.Null schema)
        <*> teamContactManagedBy .= optField "managed_by" (maybeWithDefault Aeson.Null schema)
        <*> teamContactSAMLIdp .= optField "saml_idp" (maybeWithDefault Aeson.Null schema)
        <*> teamContactRole .= optField "role" (maybeWithDefault Aeson.Null schema)
        <*> teamContactScimExternalId .= optField "scim_external_id" (maybeWithDefault Aeson.Null schema)
        <*> teamContactSso .= optField "sso" (maybeWithDefault Aeson.Null schema)
        <*> teamContactEmailUnvalidated .= optField "email_unvalidated" (maybeWithDefault Aeson.Null schema)
        <*> teamContactUserGroups .= fieldWithDocModifier "user_groups" (S.description ?~ "List of user group ids the user is a member of") (array schema)
        <*> teamContactSearchable .= field "searchable" schema

data TeamUserSearchSortBy
  = SortByName
  | SortByHandle
  | SortByEmail
  | SortBySAMLIdp
  | SortByManagedBy
  | SortByRole
  | SortByCreatedAt
  deriving (Show, Eq, Ord, Generic, Enum, Bounded)
  deriving (Arbitrary) via (GenericUniform TeamUserSearchSortBy)

instance S.ToParamSchema TeamUserSearchSortBy where
  toParamSchema _ =
    mempty
      & S.type_ ?~ S.OpenApiString
      & S.enum_ ?~ fmap teamUserSearchSortByName [minBound .. maxBound]

instance ToByteString TeamUserSearchSortBy where
  builder = teamUserSearchSortByName

instance FromByteString TeamUserSearchSortBy where
  parser =
    asum $
      [minBound .. maxBound] <&> \ctor ->
        ctor <$ string (teamUserSearchSortByName ctor)

instance FromHttpApiData TeamUserSearchSortBy where
  parseQueryParam name = note ("Unknown search sort: " <> name) $
    getAlt $
      flip foldMap [minBound .. maxBound] $ \s ->
        guard (teamUserSearchSortByName s == name) $> s

teamUserSearchSortByName :: (IsString a) => TeamUserSearchSortBy -> a
teamUserSearchSortByName SortByName = "name"
teamUserSearchSortByName SortByHandle = "handle"
teamUserSearchSortByName SortByEmail = "email"
teamUserSearchSortByName SortBySAMLIdp = "saml_idp"
teamUserSearchSortByName SortByManagedBy = "managed_by"
teamUserSearchSortByName SortByRole = "role"
teamUserSearchSortByName SortByCreatedAt = "created_at"

data TeamUserSearchSortOrder
  = SortOrderAsc
  | SortOrderDesc
  deriving (Show, Eq, Ord, Generic, Enum, Bounded)
  deriving (Arbitrary) via (GenericUniform TeamUserSearchSortOrder)

instance S.ToParamSchema TeamUserSearchSortOrder where
  toParamSchema _ =
    mempty
      & S.type_ ?~ S.OpenApiString
      & S.enum_ ?~ fmap teamUserSearchSortOrderName [minBound .. maxBound]

instance ToByteString TeamUserSearchSortOrder where
  builder = teamUserSearchSortOrderName

instance FromByteString TeamUserSearchSortOrder where
  parser =
    asum $
      [minBound .. maxBound] <&> \ctor ->
        ctor <$ string (teamUserSearchSortOrderName ctor)

instance FromHttpApiData TeamUserSearchSortOrder where
  parseQueryParam name = note ("Unknown search order: " <> name) $
    getAlt $
      flip foldMap [minBound .. maxBound] $ \s ->
        guard (teamUserSearchSortOrderName s == name) $> s

teamUserSearchSortOrderName :: (IsString a) => TeamUserSearchSortOrder -> a
teamUserSearchSortOrderName SortOrderAsc = "asc"
teamUserSearchSortOrderName SortOrderDesc = "desc"

newtype RoleFilter = RoleFilter [Role]
  deriving (Show, Eq, Generic)
  deriving (Arbitrary) via (GenericUniform RoleFilter)

instance S.ToParamSchema RoleFilter where
  toParamSchema _ = S.toParamSchema (Proxy @[Role])

instance ToByteString RoleFilter where
  builder (RoleFilter roles) = mconcat $ intersperse "," (fmap builder roles)

instance FromByteString RoleFilter where
  parser = do
    parts <- C8.split ',' <$> parser
    RoleFilter <$> traverse (maybe (fail "Invalid role") pure . fromByteString) parts

-- In some places, we don't have bots as an option, so we don't want
-- to use 'UserType'.  Once bots are removed from the picture,
-- 'UserType' and 'UserTypeFilter' will be the same ething.
data UserTypeFilter = UserTypeFilterRegular | UserTypeFilterApp
  deriving (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform UserTypeFilter)
  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via (Schema UserTypeFilter)

userTypeFilterToText :: UserTypeFilter -> Text
userTypeFilterToText = TE.decodeUtf8 . toByteString'

userTypeFilterToUserType :: UserTypeFilter -> UserType
userTypeFilterToUserType UserTypeFilterRegular = UserTypeRegular
userTypeFilterToUserType UserTypeFilterApp = UserTypeApp

instance ToSchema UserTypeFilter where
  schema =
    enum @Text $
      mconcat
        [ element "regular" UserTypeFilterRegular,
          element "app" UserTypeFilterApp
        ]

instance FromByteString UserTypeFilter where
  parser =
    AP.takeByteString
      >>= \case
        "regular" -> pure UserTypeFilterRegular
        "app" -> pure UserTypeFilterApp
        x -> fail $ "Invalid UserTypeFilter value: " <> show x

instance ToByteString UserTypeFilter where
  builder UserTypeFilterRegular = "regular"
  builder UserTypeFilterApp = "app"

instance FromHttpApiData RoleFilter where
  parseQueryParam = fmap RoleFilter . traverse parseQueryParam . T.split (== ',')

data FederatedUserSearchPolicy
  = NoSearch
  | ExactHandleSearch
  | FullSearch
  deriving (Show, Eq, Ord, Generic, Enum, Bounded)
  deriving (Arbitrary) via (GenericUniform FederatedUserSearchPolicy)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema FederatedUserSearchPolicy)

instance ToSchema FederatedUserSearchPolicy where
  schema =
    enum @Text $
      element "no_search" NoSearch
        <> element "exact_handle_search" ExactHandleSearch
        <> element "full_search" FullSearch

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

  toCql NoSearch = C.CqlInt 0
  toCql ExactHandleSearch = C.CqlInt 1
  toCql FullSearch = C.CqlInt 2

  fromCql (C.CqlInt 0) = pure NoSearch
  fromCql (C.CqlInt 1) = pure ExactHandleSearch
  fromCql (C.CqlInt 2) = pure FullSearch
  fromCql n = Left $ "Unexpected SearchVisibilityInbound: " ++ show n

data EmailVerificationFilter
  = EmailUnverified
  | EmailVerified
  deriving (Eq, Show, Generic, Enum, Bounded)
  deriving (Arbitrary) via (GenericUniform EmailVerificationFilter)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema EmailVerificationFilter)

instance ToSchema EmailVerificationFilter where
  schema =
    enum @Text $
      element "unverified" EmailUnverified
        <> element "verified" EmailVerified

instance ToByteString EmailVerificationFilter where
  builder EmailUnverified = "unverified"
  builder EmailVerified = "verified"

instance FromByteString EmailVerificationFilter where
  parser =
    asum $
      [ EmailUnverified <$ string "unverified",
        EmailVerified <$ string "verified"
      ]

instance FromHttpApiData EmailVerificationFilter where
  parseQueryParam = mapLeft T.pack . runParser parser . TE.encodeUtf8

instance ToHttpApiData EmailVerificationFilter where
  toQueryParam = TE.decodeUtf8 . BS.toByteString'

instance S.ToParamSchema EmailVerificationFilter where
  toParamSchema _ =
    mempty
      & S.type_ ?~ S.OpenApiString
      & S.enum_ ?~ ["unverified", "verified"]

data SetSearchable = SetSearchable
  { setSearchable :: Bool
  }
  deriving (Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema SetSearchable)

instance ToSchema SetSearchable where
  schema =
    object $
      SetSearchable
        <$> setSearchable .= field "set_searchable" schema
