{-# LANGUAGE UndecidableInstances #-}

module Mensam.Server.Application.Secret where

import Mensam.Server.Application.Configured.Class
import Mensam.Server.Application.Secret.Class
import Mensam.Server.Application.SeldaPool.Class
import Mensam.Server.Secrets

import Control.Monad.Logger.CallStack
import Control.Monad.Trans
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Control
import Control.Monad.Trans.Control.Identity
import Control.Monad.Trans.Reader
import Data.Kind
import Data.Text qualified as T

type SecretT :: (Type -> Type) -> Type -> Type
newtype SecretT m a = SecretT {forall (m :: * -> *) a. SecretT m a -> ReaderT Secrets m a
unSecretT :: ReaderT Secrets m a}
  deriving newtype (Functor (SecretT m)
Functor (SecretT m) =>
(forall a. a -> SecretT m a)
-> (forall a b. SecretT m (a -> b) -> SecretT m a -> SecretT m b)
-> (forall a b c.
    (a -> b -> c) -> SecretT m a -> SecretT m b -> SecretT m c)
-> (forall a b. SecretT m a -> SecretT m b -> SecretT m b)
-> (forall a b. SecretT m a -> SecretT m b -> SecretT m a)
-> Applicative (SecretT m)
forall a. a -> SecretT m a
forall a b. SecretT m a -> SecretT m b -> SecretT m a
forall a b. SecretT m a -> SecretT m b -> SecretT m b
forall a b. SecretT m (a -> b) -> SecretT m a -> SecretT m b
forall a b c.
(a -> b -> c) -> SecretT m a -> SecretT m b -> SecretT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SecretT m)
forall (m :: * -> *) a. Applicative m => a -> SecretT m a
forall (m :: * -> *) a b.
Applicative m =>
SecretT m a -> SecretT m b -> SecretT m a
forall (m :: * -> *) a b.
Applicative m =>
SecretT m a -> SecretT m b -> SecretT m b
forall (m :: * -> *) a b.
Applicative m =>
SecretT m (a -> b) -> SecretT m a -> SecretT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SecretT m a -> SecretT m b -> SecretT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SecretT m a
pure :: forall a. a -> SecretT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SecretT m (a -> b) -> SecretT m a -> SecretT m b
<*> :: forall a b. SecretT m (a -> b) -> SecretT m a -> SecretT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SecretT m a -> SecretT m b -> SecretT m c
liftA2 :: forall a b c.
(a -> b -> c) -> SecretT m a -> SecretT m b -> SecretT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SecretT m a -> SecretT m b -> SecretT m b
*> :: forall a b. SecretT m a -> SecretT m b -> SecretT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SecretT m a -> SecretT m b -> SecretT m a
<* :: forall a b. SecretT m a -> SecretT m b -> SecretT m a
Applicative, (forall a b. (a -> b) -> SecretT m a -> SecretT m b)
-> (forall a b. a -> SecretT m b -> SecretT m a)
-> Functor (SecretT m)
forall a b. a -> SecretT m b -> SecretT m a
forall a b. (a -> b) -> SecretT m a -> SecretT m b
forall (m :: * -> *) a b.
Functor m =>
a -> SecretT m b -> SecretT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SecretT m a -> SecretT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SecretT m a -> SecretT m b
fmap :: forall a b. (a -> b) -> SecretT m a -> SecretT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SecretT m b -> SecretT m a
<$ :: forall a b. a -> SecretT m b -> SecretT m a
Functor, Applicative (SecretT m)
Applicative (SecretT m) =>
(forall a b. SecretT m a -> (a -> SecretT m b) -> SecretT m b)
-> (forall a b. SecretT m a -> SecretT m b -> SecretT m b)
-> (forall a. a -> SecretT m a)
-> Monad (SecretT m)
forall a. a -> SecretT m a
forall a b. SecretT m a -> SecretT m b -> SecretT m b
forall a b. SecretT m a -> (a -> SecretT m b) -> SecretT m b
forall (m :: * -> *). Monad m => Applicative (SecretT m)
forall (m :: * -> *) a. Monad m => a -> SecretT m a
forall (m :: * -> *) a b.
Monad m =>
SecretT m a -> SecretT m b -> SecretT m b
forall (m :: * -> *) a b.
Monad m =>
SecretT m a -> (a -> SecretT m b) -> SecretT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SecretT m a -> (a -> SecretT m b) -> SecretT m b
>>= :: forall a b. SecretT m a -> (a -> SecretT m b) -> SecretT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SecretT m a -> SecretT m b -> SecretT m b
>> :: forall a b. SecretT m a -> SecretT m b -> SecretT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> SecretT m a
return :: forall a. a -> SecretT m a
Monad)
  deriving newtype ((forall (m :: * -> *). Monad m => Monad (SecretT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> SecretT m a)
-> MonadTrans SecretT
forall (m :: * -> *). Monad m => Monad (SecretT m)
forall (m :: * -> *) a. Monad m => m a -> SecretT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> SecretT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> SecretT m a
MonadTrans, MonadTrans SecretT
MonadTrans SecretT =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run SecretT -> m a) -> SecretT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT SecretT a) -> SecretT m a)
-> MonadTransControl SecretT
forall (m :: * -> *) a. Monad m => m (StT SecretT a) -> SecretT m a
forall (m :: * -> *) a.
Monad m =>
(Run SecretT -> m a) -> SecretT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run SecretT -> m a) -> SecretT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run SecretT -> m a) -> SecretT m a
$crestoreT :: forall (m :: * -> *) a. Monad m => m (StT SecretT a) -> SecretT m a
restoreT :: forall (m :: * -> *) a. Monad m => m (StT SecretT a) -> SecretT m a
MonadTransControl, MonadTransControl SecretT
MonadTransControl SecretT =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. SecretT m x -> m x) -> m a) -> SecretT m a)
-> MonadTransControlIdentity SecretT
forall (m :: * -> *) a.
Monad m =>
((forall x. SecretT m x -> m x) -> m a) -> SecretT m a
forall (t :: (* -> *) -> * -> *).
MonadTransControl t =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. t m x -> m x) -> m a) -> t m a)
-> MonadTransControlIdentity t
$cliftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. SecretT m x -> m x) -> m a) -> SecretT m a
liftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. SecretT m x -> m x) -> m a) -> SecretT m a
MonadTransControlIdentity)

instance Monad m => MonadSecret (SecretT m) where
  secrets :: SecretT m Secrets
secrets = ReaderT Secrets m Secrets -> SecretT m Secrets
forall (m :: * -> *) a. ReaderT Secrets m a -> SecretT m a
SecretT ReaderT Secrets m Secrets
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

deriving via
  SecretT ((t2 :: (Type -> Type) -> Type -> Type) m)
  instance
    Monad (t2 m) => MonadSecret (ComposeT SecretT t2 m)

runSecretT :: SecretT m a -> Secrets -> m a
runSecretT :: forall (m :: * -> *) a. SecretT m a -> Secrets -> m a
runSecretT = ReaderT Secrets m a -> Secrets -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Secrets m a -> Secrets -> m a)
-> (SecretT m a -> ReaderT Secrets m a)
-> SecretT m a
-> Secrets
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretT m a -> ReaderT Secrets m a
forall (m :: * -> *) a. SecretT m a -> ReaderT Secrets m a
unSecretT

runAppSecretT ::
  (MonadConfigured m, MonadLogger m, MonadSeldaPool m) =>
  SecretT m a ->
  m a
runAppSecretT :: forall (m :: * -> *) a.
(MonadConfigured m, MonadLogger m, MonadSeldaPool m) =>
SecretT m a -> m a
runAppSecretT SecretT m a
tma = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Acquiring secrets."

  JWK
secretsJwk <- do
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Acquiring JWK."
    SeldaResult JWK
seldaResult <- SeldaTransactionT m JWK -> m (SeldaResult JWK)
forall a. SeldaTransactionT m a -> m (SeldaResult a)
forall (m :: * -> *) a.
MonadSeldaPool m =>
SeldaTransactionT m a -> m (SeldaResult a)
runSeldaTransactionT (SeldaTransactionT m JWK -> m (SeldaResult JWK))
-> SeldaTransactionT m JWK -> m (SeldaResult JWK)
forall a b. (a -> b) -> a -> b
$ do
      Maybe JWK
maybeOldJwk <- SeldaTransactionT m (Maybe JWK)
forall (m :: * -> *).
(MonadSeldaPool m, MonadLogger m) =>
SeldaTransactionT m (Maybe JWK)
jwkGetLatest
      case Maybe JWK
maybeOldJwk of
        Just JWK
jwk -> do
          m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Using existing JWK."
          JWK -> SeldaTransactionT m JWK
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JWK
jwk
        Maybe JWK
Nothing -> do
          m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Currently there is no JWK set. Setting new JWK."
          JWK
jwk <- SeldaTransactionT m JWK
forall (m :: * -> *).
(MonadSeldaPool m, MonadLogger m) =>
SeldaTransactionT m JWK
jwkSetLatest
          m () -> SeldaTransactionT m ()
forall (m :: * -> *) a. Monad m => m a -> SeldaTransactionT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SeldaTransactionT m ()) -> m () -> SeldaTransactionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Using newly set JWK."
          JWK -> SeldaTransactionT m JWK
forall a. a -> SeldaTransactionT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JWK
jwk
    case SeldaResult JWK
seldaResult of
      SeldaFailure SomeException
err -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Failed to acquire JWK: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
        String -> m JWK
forall a. HasCallStack => String -> a
error String
"No JWK."
      SeldaSuccess JWK
jwk -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logInfo Text
"Acquired JWK successfully."
        JWK -> m JWK
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JWK
jwk

  SecretT m a -> Secrets -> m a
forall (m :: * -> *) a. SecretT m a -> Secrets -> m a
runSecretT SecretT m a
tma (Secrets -> m a) -> Secrets -> m a
forall a b. (a -> b) -> a -> b
$ MkSecrets {JWK
secretsJwk :: JWK
secretsJwk :: JWK
secretsJwk}