-- Disabling to stop warnings on HasCallStack
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

-- 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 Spar.Sem.SAMLUserStore.Cassandra
  ( samlUserStoreToCassandra,
    getAllByIssuerPaginated,
  )
where

import Cassandra as Cas
import Control.Lens
import Data.Id
import Imports
import Polysemy
import qualified SAML2.WebSSO as SAML
import qualified Spar.Data as Data
import Spar.Data.Instances ()
import Spar.Sem.SAMLUserStore
import Wire.IdPConfigStore.Orphans ()

samlUserStoreToCassandra ::
  forall m r a.
  (MonadClient m, Member (Embed m) r) =>
  Sem (SAMLUserStore ': r) a ->
  Sem r a
samlUserStoreToCassandra =
  interpret $
    embed
      . \case
        Insert ur uid -> insertSAMLUser ur uid
        Get ur -> getSAMLUser ur
        DeleteByIssuer is -> deleteSAMLUsersByIssuer is
        Delete uid ur -> deleteSAMLUser uid ur
        GetAllByIssuerPaginated is -> getAllSAMLUsersByIssuerPaginated is
        NextPage page -> nextPage' page

nextPage' :: (HasCallStack, MonadClient m) => Cas.Page a -> m (Cas.Page a)
nextPage' = Cas.liftClient . Cas.nextPage

-- | Replaces `getSAML{Some,Any}UsersByIssuer`.
-- Since we currently do not have a team id stored together with the SAML user in user_v2
-- we must get all and filter manually by asking brig for the team id when deleting an IdP.
-- FUTUREWORK: to migrate to a new table that contains the team id.
getAllSAMLUsersByIssuerPaginated :: (HasCallStack, MonadClient m) => SAML.Issuer -> m (Cas.Page (SAML.UserRef, UserId))
getAllSAMLUsersByIssuerPaginated issuer = do
  (_1 %~ SAML.UserRef issuer) <$$> retry x1 (paginate getAllByIssuer (paramsP LocalQuorum (Identity issuer) (size + 1)))
  where
    size = 200

    getAllByIssuer :: PrepQuery R (Identity SAML.Issuer) (SAML.NameID, UserId)
    getAllByIssuer = "SELECT sso_id, uid FROM user_v2 WHERE issuer = ?"

-- | Add new user.  If user with this 'SAML.UserId' exists, overwrite it.
insertSAMLUser :: (HasCallStack, MonadClient m) => SAML.UserRef -> UserId -> m ()
insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params LocalQuorum (tenant, Data.normalizeQualifiedNameId subject, subject, uid)
  where
    ins :: PrepQuery W (SAML.Issuer, Data.NormalizedUNameID, SAML.NameID, UserId) ()
    ins = "INSERT INTO user_v2 (issuer, normalized_uname_id, sso_id, uid) VALUES (?, ?, ?, ?)"

-- | Lookup a brig 'UserId' by IdP issuer and NameID.
--
-- NB: It is not allowed for two distinct wire users from two different teams to have the same
-- 'UserRef'.  RATIONALE: this allows us to implement 'getSAMLUser' without adding 'TeamId' to
-- 'UserRef' (which in turn would break the (admittedly leaky) abstarctions of saml2-web-sso).
getSAMLUser :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId)
getSAMLUser uref = do
  mbUid <- getSAMLUserNew uref
  case mbUid of
    Nothing -> migrateLegacy uref
    Just uid -> pure $ Just uid
  where
    getSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId)
    getSAMLUserNew (SAML.UserRef tenant subject) =
      runIdentity
        <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, Data.normalizeQualifiedNameId subject))
      where
        sel :: PrepQuery R (SAML.Issuer, Data.NormalizedUNameID) (Identity UserId)
        sel = "SELECT uid FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?"

    migrateLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId)
    migrateLegacy uref' = do
      mbUid <- getSAMLUserLegacy uref'
      for mbUid $ \uid -> do
        insertSAMLUser uref' uid
        pure uid

    getSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId)
    getSAMLUserLegacy (SAML.UserRef tenant subject) =
      runIdentity
        <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, subject))
      where
        sel :: PrepQuery R (SAML.Issuer, SAML.NameID) (Identity UserId)
        sel = "SELECT uid FROM user WHERE issuer = ? AND sso_id = ?"

deleteSAMLUsersByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m ()
deleteSAMLUsersByIssuer issuer = retry x5 . write del $ params LocalQuorum (Identity issuer)
  where
    del :: PrepQuery W (Identity SAML.Issuer) ()
    del = "DELETE FROM user_v2 WHERE issuer = ?"

deleteSAMLUser :: (HasCallStack, MonadClient m) => UserId -> SAML.UserRef -> m ()
deleteSAMLUser uid uref = do
  muidUref <- getSAMLUser uref
  for_ muidUref $ \uidUref ->
    when (uidUref == uid) $ do
      deleteSAMLUserLegacy uref
      deleteSAMLUserNew uref
  where
    deleteSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m ()
    deleteSAMLUserNew (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, Data.normalizeQualifiedNameId subject)
      where
        del :: PrepQuery W (SAML.Issuer, Data.NormalizedUNameID) ()
        del = "DELETE FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?"
    deleteSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m ()
    deleteSAMLUserLegacy (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, subject)
      where
        del :: PrepQuery W (SAML.Issuer, SAML.NameID) ()
        del = "DELETE FROM user WHERE issuer = ? AND sso_id = ?"
