-- Disabling to stop warnings on HasCallStack
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- 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.AReqIDStore.Cassandra
  ( aReqIDStoreToCassandra,
  )
where

import Cassandra as Cas
import Control.Lens
import Control.Monad.Except
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input (Input, input)
import qualified SAML2.WebSSO as SAML
import qualified Spar.Data as Data
import Spar.Data.Instances ()
import Spar.Options
import Spar.Sem.AReqIDStore
import Wire.API.User.Saml
import Wire.IdPConfigStore.Orphans ()
import Wire.Sem.Now (Now)
import qualified Wire.Sem.Now as Now

aReqIDStoreToCassandra ::
  forall m r a.
  ( MonadClient m,
    ( Member (Embed m) r,
      Member Now r,
      Member (Error TTLError) r,
      Member (Embed IO) r,
      Member (Input Opts) r
    )
  ) =>
  Sem (AReqIDStore ': r) a ->
  Sem r a
aReqIDStoreToCassandra = interpret $ \case
  Store itla issuer t -> do
    denv <- Data.mkEnv <$> input <*> Now.get
    a <- embed @m $ runExceptT $ runReaderT (storeAReqID itla issuer t) denv
    case a of
      Left err -> throw err
      Right () -> pure ()
  GetIdpIssuer itla -> embed @m $ getAReqID itla
  UnStore itla -> embed @m $ unStoreAReqID itla

storeAReqID ::
  (HasCallStack, MonadReader Data.Env m, MonadClient m, MonadError TTLError m) =>
  AReqId ->
  SAML.Issuer ->
  SAML.Time ->
  m ()
storeAReqID (SAML.ID rid) issuer (SAML.Time endOfLife) = do
  env <- ask
  TTL ttl <- Data.mkTTLAuthnRequests env endOfLife
  retry x5 . write ins $ params LocalQuorum (rid, issuer, ttl)
  where
    ins :: PrepQuery W (Text, SAML.Issuer, Int32) ()
    ins = "INSERT INTO authreq (req, idp_issuer) VALUES (?,?) USING TTL ?"

getAReqID ::
  (HasCallStack, MonadClient m) =>
  AReqId ->
  m (Maybe SAML.Issuer)
getAReqID (SAML.ID rid) =
  listToMaybe <$> (runIdentity <$$> (retry x1 . query sel . params LocalQuorum $ Identity rid))
  where
    sel :: PrepQuery R (Identity Text) (Identity SAML.Issuer)
    sel = "SELECT idp_issuer FROM authreq WHERE req = ?"

unStoreAReqID ::
  (HasCallStack, MonadClient m) =>
  AReqId ->
  m ()
unStoreAReqID (SAML.ID rid) = retry x5 . write del . params LocalQuorum $ Identity rid
  where
    del :: PrepQuery W (Identity Text) ()
    del = "DELETE FROM authreq WHERE req = ?"
