{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.SAML2.Library (saml2ToSaml2WebSso) where

import qualified Control.Monad.Catch as Catch
import Control.Monad.Except
import Data.Id (TeamId)
import qualified Data.Text.Lazy as LText
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Final
import Polysemy.Input
import Polysemy.Internal.Tactics
import SAML2.WebSSO hiding (Error)
import qualified SAML2.WebSSO as SAML hiding (Error)
import Spar.Error (SparCustomError (..), SparError)
import Spar.Options
import Spar.Sem.AReqIDStore (AReqIDStore)
import qualified Spar.Sem.AReqIDStore as AReqIDStore
import Spar.Sem.AssIDStore (AssIDStore)
import qualified Spar.Sem.AssIDStore as AssIDStore
import Spar.Sem.SAML2
import Wire.API.User.IdentityProvider (WireIdP)
import Wire.IdPConfigStore (IdPConfigStore)
import qualified Wire.IdPConfigStore as IdPConfigStore
import Wire.Sem.Logger (Logger)
import qualified Wire.Sem.Logger as Logger

wrapMonadClientSPImpl ::
  ( Member (Error SparError) r,
    Member (Final IO) r
  ) =>
  Sem r a ->
  SPImpl r a
wrapMonadClientSPImpl action =
  SPImpl action
    `Catch.catch` ( SPImpl
                      . throw
                      . SAML.CustomError
                      . SparCassandraError
                      . LText.pack
                      . displayException @SomeException
                  )

instance (Member (Final IO) r) => Catch.MonadThrow (SPImpl r) where
  throwM = SPImpl . embedFinal . Catch.throwM @IO

instance (Member (Final IO) r) => Catch.MonadCatch (SPImpl r) where
  catch (SPImpl m) handler = SPImpl $
    withStrategicToFinal @IO $ do
      m' <- runS m
      st <- getInitialStateS
      handler' <- bindS $ unSPImpl . handler
      pure $ m' `Catch.catch` \e -> handler' $ e <$ st

newtype SPImpl r a = SPImpl {unSPImpl :: Sem r a}
  deriving (Functor, Applicative, Monad)

instance (Member (Input Opts) r) => HasConfig (SPImpl r) where
  getConfig = SPImpl $ inputs saml

instance
  (Member (Logger String) r) =>
  HasLogger (SPImpl r)
  where
  logger lvl = SPImpl . Logger.log lvl

instance (Member (Embed IO) r) => MonadIO (SPImpl r) where
  liftIO = SPImpl . embed @IO

instance (Member (Embed IO) r) => HasCreateUUID (SPImpl r)

instance (Member (Embed IO) r) => HasNow (SPImpl r)

instance
  ( Member (Error SparError) r,
    Member (Final IO) r,
    Member AReqIDStore r
  ) =>
  SPStoreRequest AuthnRequest (SPImpl r)
  where
  storeRequest issuer timestamp = wrapMonadClientSPImpl . (AReqIDStore.store issuer timestamp)
  unStoreRequest = wrapMonadClientSPImpl . AReqIDStore.unStore
  getIdpIssuer = wrapMonadClientSPImpl . AReqIDStore.getIdpIssuer

instance
  ( Member (Error SparError) r,
    Member (Final IO) r,
    Member AssIDStore r
  ) =>
  SPStoreAssertion Assertion (SPImpl r)
  where
  storeAssertionInternal = (wrapMonadClientSPImpl .) . AssIDStore.store
  unStoreAssertion = wrapMonadClientSPImpl . AssIDStore.unStore
  isAliveAssertion = wrapMonadClientSPImpl . AssIDStore.isAlive

instance
  ( Member (Error SparError) r,
    Member IdPConfigStore r,
    Member (Final IO) r
  ) =>
  SPStoreIdP SparError (SPImpl r)
  where
  type IdPConfigExtra (SPImpl r) = WireIdP
  type IdPConfigSPId (SPImpl r) = TeamId

  storeIdPConfig = SPImpl . IdPConfigStore.insertConfig
  getIdPConfig = SPImpl . IdPConfigStore.getConfig
  getIdPConfigByIssuerOptionalSPId issuer mbteam = SPImpl $ case mbteam of
    Nothing -> IdPConfigStore.getIdPByIssuerV1 issuer
    Just team -> IdPConfigStore.getIdPByIssuerV2 issuer team

instance (Member (Error SparError) r) => MonadError SparError (SPImpl r) where
  throwError = SPImpl . throw
  catchError m handler = SPImpl $ catch (unSPImpl m) $ unSPImpl . handler

-- | To learn more about polysemy tactics, read this:
--   * https://reasonablypolymorphic.com/blog/freer-higher-order-effects/
--   * https://reasonablypolymorphic.com/blog/tactics/
saml2ToSaml2WebSso ::
  forall r a.
  ( Member AReqIDStore r,
    Member AssIDStore r,
    Member (Error SparError) r,
    Member IdPConfigStore r,
    Member (Input Opts) r,
    Member (Logger String) r,
    Member (Embed IO) r,
    Member (Final IO) r
  ) =>
  Sem (SAML2 ': r) a ->
  Sem r a
saml2ToSaml2WebSso =
  interpretH $ \case
    AuthReq n ma i -> do
      get_a <- runT ma
      ins <- getInspectorT
      x <- raise $ unSPImpl $ SAML.authreq @_ @SparError n (inspectOrBomb ins get_a) i
      s <- getInitialStateT
      pure $ x <$ s
    AuthResp mitlt ma mb mc ab -> do
      get_a <- runT ma
      get_b <- runT mb
      get_c <- bindT $ \(a, (b, c)) -> mc a b c
      ins <- getInspectorT
      s <- getInitialStateT
      x <-
        raise $
          unSPImpl $
            SAML.authresp
              mitlt
              (inspectOrBomb ins get_a)
              (inspectOrBomb ins get_b)
              (\x y z -> inspectOrBomb ins $ get_c $ (x, (y, z)) <$ s)
              ab
      pure $ x <$ s
    Meta t ma mb mc -> do
      get_a <- runT ma
      get_b <- runT mb
      get_c <- runT mc
      ins <- getInspectorT
      x <- raise $ unSPImpl $ SAML.meta t (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) (inspectOrBomb ins get_c)
      s <- getInitialStateT
      pure $ x <$ s
    ToggleCookie sbs mp -> do
      liftT $ unSPImpl $ SAML.toggleCookie sbs mp

inspectOrBomb ::
  ( Member AReqIDStore r,
    Member AssIDStore r,
    Member (Error SparError) r,
    Member IdPConfigStore r,
    Member (Logger String) r,
    Member (Input Opts) r,
    Member (Embed IO) r,
    Member (Final IO) r
  ) =>
  Inspector f ->
  Sem (SAML2 : r) (f b) ->
  SPImpl r b
inspectOrBomb ins get_a = do
  fa <- SPImpl $ saml2ToSaml2WebSso get_a
  maybe
    (SPImpl . throw @SparError $ SAML.CustomError $ SparInternalError "saml2ToSaml2WebSso called with an uninspectable weaving functor")
    pure
    $ inspect ins fa
