{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE RankNTypes       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}
{-

A handler for the 'ContractStore'  effect that stores everything in a TVar.

-}
module Plutus.PAB.Db.Memory.ContractStore(
    InMemContractInstanceState(..)
    , handleContractStore
    , InMemInstances
    , initialInMemInstances
    ) where

import Control.Concurrent.STM (TVar)
import Control.Concurrent.STM qualified as STM
import Control.Monad.Freer (Eff, LastMember, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Reader (Reader, ask)
import Control.Monad.IO.Class (MonadIO (..))
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.Map (Map)
import Data.Map qualified as Map
import Plutus.PAB.Effects.Contract (ContractStore)
import Plutus.PAB.Effects.Contract qualified as Contract
import Plutus.PAB.Types (PABError (..))
import Plutus.PAB.Webserver.Types (ContractActivationArgs)
import Wallet.Types (ContractInstanceId)

-- | The current state of a contract instance
-- Considering InstanceState contractState as mutable to avoid bottleneck when updating InMemInstances especially
-- when an instance already exists. Note also that PutState is adjusted so as to avoid full map update
-- when instance already exists.
data InMemContractInstanceState t =
    InMemContractInstanceState
        { InMemContractInstanceState t
-> ContractActivationArgs (ContractDef t)
_contractDef   :: ContractActivationArgs (Contract.ContractDef t)
        , InMemContractInstanceState t -> TVar (State t)
_contractState :: TVar (Contract.State t)
        }

newtype InMemInstances t = InMemInstances { InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
unInMemInstances :: IORef (Map ContractInstanceId (InMemContractInstanceState t)) }

initialInMemInstances :: forall t. IO (InMemInstances t)
initialInMemInstances :: IO (InMemInstances t)
initialInMemInstances = IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> InMemInstances t
forall t.
IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> InMemInstances t
InMemInstances (IORef (Map ContractInstanceId (InMemContractInstanceState t))
 -> InMemInstances t)
-> IO
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
-> IO (InMemInstances t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ContractInstanceId (InMemContractInstanceState t)
-> IO
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
forall a. a -> IO (IORef a)
IORef.newIORef Map ContractInstanceId (InMemContractInstanceState t)
forall a. Monoid a => a
mempty

-- | Handle the 'ContractStore' effect by writing the state to the
--   TVar in 'SimulatorState'
handleContractStore ::
    forall t effs.
    ( LastMember IO effs
    , Member (Reader (InMemInstances t)) effs
    , Member (Error PABError) effs
    )
    => ContractStore t
    ~> Eff effs
handleContractStore :: ContractStore t ~> Eff effs
handleContractStore = \case
    Contract.PutState ContractActivationArgs (ContractDef t)
definition ContractInstanceId
instanceId State t
state -> do
        IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar <- InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
forall t.
InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
unInMemInstances (InMemInstances t
 -> IORef (Map ContractInstanceId (InMemContractInstanceState t)))
-> Eff effs (InMemInstances t)
-> Eff
     effs
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (Reader (InMemInstances t)) effs =>
Eff effs (InMemInstances t)
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @(InMemInstances t)
        Map ContractInstanceId (InMemContractInstanceState t)
instances <- IO (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ContractInstanceId (InMemContractInstanceState t))
 -> Eff
      effs (Map ContractInstanceId (InMemContractInstanceState t)))
-> IO (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
forall a b. (a -> b) -> a -> b
$ IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> IO (Map ContractInstanceId (InMemContractInstanceState t))
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar
        case ContractInstanceId
-> Map ContractInstanceId (InMemContractInstanceState t)
-> Maybe (InMemContractInstanceState t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContractInstanceId
instanceId Map ContractInstanceId (InMemContractInstanceState t)
instances of
          Maybe (InMemContractInstanceState t)
Nothing -> do
            -- adding new entry
            TVar (State t)
stateTVar <- IO (TVar (State t)) -> Eff effs (TVar (State t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (State t -> IO (TVar (State t))
forall a. a -> IO (TVar a)
STM.newTVarIO State t
state)
            let instState :: InMemContractInstanceState t
instState = InMemContractInstanceState :: forall t.
ContractActivationArgs (ContractDef t)
-> TVar (State t) -> InMemContractInstanceState t
InMemContractInstanceState{_contractDef :: ContractActivationArgs (ContractDef t)
_contractDef = ContractActivationArgs (ContractDef t)
definition, _contractState :: TVar (State t)
_contractState = TVar (State t)
stateTVar}
            IO () -> Eff effs ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff effs ()) -> IO () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> (Map ContractInstanceId (InMemContractInstanceState t)
    -> Map ContractInstanceId (InMemContractInstanceState t))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar (ContractInstanceId
-> InMemContractInstanceState t
-> Map ContractInstanceId (InMemContractInstanceState t)
-> Map ContractInstanceId (InMemContractInstanceState t)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContractInstanceId
instanceId InMemContractInstanceState t
instState)
          Just InMemContractInstanceState t
oldInstState -> do
            -- only update state
            IO () -> Eff effs ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff effs ()) -> IO () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TVar (State t) -> (State t -> State t) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar (InMemContractInstanceState t -> TVar (State t)
forall t. InMemContractInstanceState t -> TVar (State t)
_contractState InMemContractInstanceState t
oldInstState) (\State t
_ -> State t
state)

    Contract.GetState ContractInstanceId
instanceId -> do
        IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar <- InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
forall t.
InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
unInMemInstances (InMemInstances t
 -> IORef (Map ContractInstanceId (InMemContractInstanceState t)))
-> Eff effs (InMemInstances t)
-> Eff
     effs
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (Reader (InMemInstances t)) effs =>
Eff effs (InMemInstances t)
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @(InMemInstances t)
        Map ContractInstanceId (InMemContractInstanceState t)
instances <- IO (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ContractInstanceId (InMemContractInstanceState t))
 -> Eff
      effs (Map ContractInstanceId (InMemContractInstanceState t)))
-> IO (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
forall a b. (a -> b) -> a -> b
$ IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> IO (Map ContractInstanceId (InMemContractInstanceState t))
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar
        case ContractInstanceId
-> Map ContractInstanceId (InMemContractInstanceState t)
-> Maybe (InMemContractInstanceState t)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContractInstanceId
instanceId Map ContractInstanceId (InMemContractInstanceState t)
instances of
          Maybe (InMemContractInstanceState t)
Nothing -> PABError -> Eff effs x
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (ContractInstanceId -> PABError
ContractInstanceNotFound ContractInstanceId
instanceId)
          Just InMemContractInstanceState t
instState ->
            IO x -> Eff effs x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> Eff effs x) -> IO x -> Eff effs x
forall a b. (a -> b) -> a -> b
$ STM x -> IO x
forall a. STM a -> IO a
STM.atomically (STM x -> IO x) -> STM x -> IO x
forall a b. (a -> b) -> a -> b
$ TVar x -> STM x
forall a. TVar a -> STM a
STM.readTVar (TVar x -> STM x) -> TVar x -> STM x
forall a b. (a -> b) -> a -> b
$ InMemContractInstanceState t -> TVar (State t)
forall t. InMemContractInstanceState t -> TVar (State t)
_contractState InMemContractInstanceState t
instState

    Contract.GetContracts Maybe ContractActivityStatus
_ -> do
        IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar <- InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
forall t.
InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
unInMemInstances (InMemInstances t
 -> IORef (Map ContractInstanceId (InMemContractInstanceState t)))
-> Eff effs (InMemInstances t)
-> Eff
     effs
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (Reader (InMemInstances t)) effs =>
Eff effs (InMemInstances t)
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @(InMemInstances t)
        (InMemContractInstanceState t
 -> ContractActivationArgs (ContractDef t))
-> Map ContractInstanceId (InMemContractInstanceState t)
-> Map ContractInstanceId (ContractActivationArgs (ContractDef t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InMemContractInstanceState t
-> ContractActivationArgs (ContractDef t)
forall t.
InMemContractInstanceState t
-> ContractActivationArgs (ContractDef t)
_contractDef (Map ContractInstanceId (InMemContractInstanceState t)
 -> Map ContractInstanceId (ContractActivationArgs (ContractDef t)))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff
     effs
     (Map ContractInstanceId (ContractActivationArgs (ContractDef t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map ContractInstanceId (InMemContractInstanceState t))
-> Eff effs (Map ContractInstanceId (InMemContractInstanceState t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> IO (Map ContractInstanceId (InMemContractInstanceState t))
forall a. IORef a -> IO a
IORef.readIORef IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar)
    Contract.PutStartInstance{} -> () -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Contract.PutStopInstance{} -> () -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Contract.DeleteState ContractInstanceId
i -> do
      IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar <- InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
forall t.
InMemInstances t
-> IORef (Map ContractInstanceId (InMemContractInstanceState t))
unInMemInstances (InMemInstances t
 -> IORef (Map ContractInstanceId (InMemContractInstanceState t)))
-> Eff effs (InMemInstances t)
-> Eff
     effs
     (IORef (Map ContractInstanceId (InMemContractInstanceState t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (effs :: [* -> *]).
Member (Reader (InMemInstances t)) effs =>
Eff effs (InMemInstances t)
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @(InMemInstances t)
      IO () -> Eff effs ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map ContractInstanceId (InMemContractInstanceState t))
-> (Map ContractInstanceId (InMemContractInstanceState t)
    -> Map ContractInstanceId (InMemContractInstanceState t))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (Map ContractInstanceId (InMemContractInstanceState t))
instancesTVar (ContractInstanceId
-> Map ContractInstanceId (InMemContractInstanceState t)
-> Map ContractInstanceId (InMemContractInstanceState t)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ContractInstanceId
i))