{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-

'beam' handler for the 'ContractStore' effect

-}
module Plutus.PAB.Db.Beam.ContractStore
  (handleContractStore)
  where

import Control.Lens
import Control.Monad (join)
import Control.Monad.Freer (Eff, Member, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras (LogMsg)
import Control.Monad.Freer.Extras.Beam (BeamEffect (..), Synt, addRows, deleteRows, selectList, selectOne, updateRows)
import Data.Aeson (FromJSON, ToJSON, decode, encode)
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding (encodeUtf8Builder)
import Data.Text.Encoding qualified as Text
import Data.Typeable (Proxy (..), typeRep)
import Data.UUID (fromText, toText)
import Database.Beam
import Database.Beam.Backend (HasSqlValueSyntax, SqlNull)
import Plutus.PAB.Db.Schema hiding (ContractInstanceId)
import Plutus.PAB.Effects.Contract (ContractStore (..), PABContract (..))
import Plutus.PAB.Effects.Contract.Builtin (Builtin, HasDefinitions (getContract), fromResponse, getResponse)
import Plutus.PAB.Monitoring.Monitoring (PABMultiAgentMsg)
import Plutus.PAB.Types (PABError (..))
import Plutus.PAB.Webserver.Types (ContractActivationArgs (..))
import Wallet.Emulator.Wallet (Wallet (..))
import Wallet.Emulator.Wallet qualified as Wallet
import Wallet.Types (ContractActivityStatus (..), ContractInstanceId (..))

-- | Convert from the internal representation of a contract into the database
-- representation.
mkRow
  :: (ToJSON a)
  => ContractActivationArgs (ContractDef (Builtin a))
  -> ContractInstanceId
  -> ContractInstance
mkRow :: ContractActivationArgs (ContractDef (Builtin a))
-> ContractInstanceId -> ContractInstance
mkRow ContractActivationArgs{ContractDef (Builtin a)
caID :: forall t. ContractActivationArgs t -> t
caID :: ContractDef (Builtin a)
caID, Maybe Wallet
caWallet :: forall t. ContractActivationArgs t -> Maybe Wallet
caWallet :: Maybe Wallet
caWallet} ContractInstanceId
instanceId
  = Columnar Identity Text
-> Columnar Identity Text
-> Columnar Identity Text
-> Columnar Identity (Maybe Text)
-> Columnar Identity Bool
-> ContractInstance
forall (f :: * -> *).
Columnar f Text
-> Columnar f Text
-> Columnar f Text
-> Columnar f (Maybe Text)
-> Columnar f Bool
-> ContractInstanceT f
ContractInstance
      (ContractInstanceId -> Text
uuidStr ContractInstanceId
instanceId)
      (ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
LB.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
ContractDef (Builtin a)
caID)
      (WalletId -> Text
Wallet.toBase16 (WalletId -> Text)
-> (Maybe Wallet -> WalletId) -> Maybe Wallet -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> WalletId
getWalletId (Wallet -> WalletId)
-> (Maybe Wallet -> Wallet) -> Maybe Wallet -> WalletId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wallet -> Maybe Wallet -> Wallet
forall a. a -> Maybe a -> a
fromMaybe (Integer -> Wallet
Wallet.knownWallet Integer
1) (Maybe Wallet -> Text) -> Maybe Wallet -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Wallet
caWallet)
      Columnar Identity (Maybe Text)
forall a. Maybe a
Nothing -- No state, initially
      Bool
Columnar Identity Bool
True    -- 'Active' immediately

-- | Convert from the database representation of a contract into the
-- internal representation.
mkContracts
  :: forall a.
  ( FromJSON a )
  => [ContractInstance]
  -> Map ContractInstanceId (ContractActivationArgs (ContractDef (Builtin a)))
mkContracts :: [ContractInstance]
-> Map
     ContractInstanceId
     (ContractActivationArgs (ContractDef (Builtin a)))
mkContracts [ContractInstance]
xs =
  [(ContractInstanceId, ContractActivationArgs a)]
-> Map ContractInstanceId (ContractActivationArgs a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ContractInstanceId, ContractActivationArgs a)]
xs'
    where
      -- Silently drop those items that failed to decode to UUIDs and contract id
      xs' :: [(ContractInstanceId, ContractActivationArgs a)]
xs'    = [ (ContractInstanceId
k, ContractActivationArgs a
v) | Just (ContractInstanceId
k, ContractActivationArgs a
v) <- (ContractInstance
 -> Maybe (ContractInstanceId, ContractActivationArgs a))
-> [ContractInstance]
-> [Maybe (ContractInstanceId, ContractActivationArgs a)]
forall a b. (a -> b) -> [a] -> [b]
map ContractInstance
-> Maybe (ContractInstanceId, ContractActivationArgs a)
forall t (f :: * -> *).
(FromJSON t, Columnar f Text ~ Text) =>
ContractInstanceT f
-> Maybe (ContractInstanceId, ContractActivationArgs t)
f [ContractInstance]
xs ]
      toId :: Text -> Maybe ContractInstanceId
toId Text
i = UUID -> ContractInstanceId
ContractInstanceId (UUID -> ContractInstanceId)
-> Maybe UUID -> Maybe ContractInstanceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe UUID
fromText Text
i
      f :: ContractInstanceT f
-> Maybe (ContractInstanceId, ContractActivationArgs t)
f ContractInstanceT f
ci   = do
          ContractInstanceId
ciId <- Text -> Maybe ContractInstanceId
toId (Text -> Maybe ContractInstanceId)
-> Text -> Maybe ContractInstanceId
forall a b. (a -> b) -> a -> b
$ ContractInstanceT f -> Columnar f Text
forall (f :: * -> *). ContractInstanceT f -> Columnar f Text
_contractInstanceId ContractInstanceT f
ci
          t
contractId <- ByteString -> Maybe t
forall a. FromJSON a => ByteString -> Maybe a
decode
                      (ByteString -> Maybe t)
-> (ContractInstanceT f -> ByteString)
-> ContractInstanceT f
-> Maybe t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
                      (Builder -> ByteString)
-> (ContractInstanceT f -> Builder)
-> ContractInstanceT f
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodeUtf8Builder
                      (Text -> Builder)
-> (ContractInstanceT f -> Text) -> ContractInstanceT f -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceT f -> Text
forall (f :: * -> *). ContractInstanceT f -> Columnar f Text
_contractInstanceContractId
                      (ContractInstanceT f -> Maybe t) -> ContractInstanceT f -> Maybe t
forall a b. (a -> b) -> a -> b
$ ContractInstanceT f
ci
          Wallet
wallet <- (WalletId -> Wallet) -> Maybe WalletId -> Maybe Wallet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String -> WalletId -> Wallet
Wallet Maybe String
forall a. Maybe a
Nothing) (Maybe WalletId -> Maybe Wallet)
-> (ContractInstanceT f -> Maybe WalletId)
-> ContractInstanceT f
-> Maybe Wallet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe WalletId)
-> (WalletId -> Maybe WalletId)
-> Either String WalletId
-> Maybe WalletId
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe WalletId -> String -> Maybe WalletId
forall a b. a -> b -> a
const Maybe WalletId
forall a. Maybe a
Nothing) WalletId -> Maybe WalletId
forall a. a -> Maybe a
Just (Either String WalletId -> Maybe WalletId)
-> (ContractInstanceT f -> Either String WalletId)
-> ContractInstanceT f
-> Maybe WalletId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String WalletId
Wallet.fromBase16 (Text -> Either String WalletId)
-> (ContractInstanceT f -> Text)
-> ContractInstanceT f
-> Either String WalletId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceT f -> Text
forall (f :: * -> *). ContractInstanceT f -> Columnar f Text
_contractInstanceWallet (ContractInstanceT f -> Maybe Wallet)
-> ContractInstanceT f -> Maybe Wallet
forall a b. (a -> b) -> a -> b
$ ContractInstanceT f
ci
          (ContractInstanceId, ContractActivationArgs t)
-> Maybe (ContractInstanceId, ContractActivationArgs t)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ContractInstanceId
ciId
                 , t -> Maybe Wallet -> ContractActivationArgs t
forall t. t -> Maybe Wallet -> ContractActivationArgs t
ContractActivationArgs t
contractId (Wallet -> Maybe Wallet
forall a. a -> Maybe a
Just Wallet
wallet)
                 )

-- | Our database doesn't store UUIDs natively, so we need to convert them
-- from a string.
uuidStr :: ContractInstanceId -> Text
uuidStr :: ContractInstanceId -> Text
uuidStr = UUID -> Text
toText (UUID -> Text)
-> (ContractInstanceId -> UUID) -> ContractInstanceId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractInstanceId -> UUID
unContractInstanceId

-- | Run the 'ContractStore' actions against the database.
handleContractStore ::
  forall dbt a effs.
  ( FromBackendRow dbt Text
  , FromBackendRow dbt Bool
  , FromBackendRow dbt SqlNull
  , HasSqlValueSyntax (Synt dbt) (Maybe Text)
  , HasSqlValueSyntax (Synt dbt) Text
  , HasSqlValueSyntax (Synt dbt) Bool
  , HasSqlEqualityCheck dbt Text
  , HasSqlEqualityCheck dbt Bool
  , HasQBuilder dbt
  , Member (BeamEffect dbt) effs
  , Member (Error PABError) effs
  , Member (LogMsg (PABMultiAgentMsg (Builtin a))) effs
  , ToJSON a
  , FromJSON a
  , HasDefinitions a
  , Typeable a
  )
  => ContractStore (Builtin a)
  ~> Eff effs
handleContractStore :: ContractStore (Builtin a) ~> Eff effs
handleContractStore = \case
  PutStartInstance ContractActivationArgs (ContractDef (Builtin a))
args ContractInstanceId
instanceId ->
    forall dbt (table :: (* -> *) -> *) (effs :: [* -> *]).
(BeamableDb dbt table, Member (BeamEffect dbt) effs) =>
SqlInsert dbt table -> Eff effs ()
forall (table :: (* -> *) -> *) (effs :: [* -> *]).
(BeamableDb dbt table, Member (BeamEffect dbt) effs) =>
SqlInsert dbt table -> Eff effs ()
addRows @dbt
      (SqlInsert dbt ContractInstanceT -> Eff effs ())
-> SqlInsert dbt ContractInstanceT -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> SqlInsertValues dbt (ContractInstanceT (QExpr dbt Any))
-> SqlInsert dbt ContractInstanceT
forall be (table :: (* -> *) -> *) s (db :: (* -> *) -> *).
(BeamSqlBackend be,
 ProjectibleWithPredicate AnyType () Text (table (QField s))) =>
DatabaseEntity be db (TableEntity table)
-> SqlInsertValues be (table (QExpr be s)) -> SqlInsert be table
insert (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
      (SqlInsertValues dbt (ContractInstanceT (QExpr dbt Any))
 -> SqlInsert dbt ContractInstanceT)
-> SqlInsertValues dbt (ContractInstanceT (QExpr dbt Any))
-> SqlInsert dbt ContractInstanceT
forall a b. (a -> b) -> a -> b
$ [ContractInstance]
-> SqlInsertValues dbt (ContractInstanceT (QExpr dbt Any))
forall be (table :: (* -> *) -> *) s.
(BeamSqlBackend be, Beamable table,
 FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table) =>
[table Identity] -> SqlInsertValues be (table (QExpr be s))
insertValues [ ContractActivationArgs (ContractDef (Builtin a))
-> ContractInstanceId -> ContractInstance
forall a.
ToJSON a =>
ContractActivationArgs (ContractDef (Builtin a))
-> ContractInstanceId -> ContractInstance
mkRow ContractActivationArgs (ContractDef (Builtin a))
args ContractInstanceId
instanceId ]

  PutState ContractActivationArgs (ContractDef (Builtin a))
_ ContractInstanceId
instanceId State (Builtin a)
state ->
    let encode' :: SomeBuiltinState a -> Text
encode' = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (SomeBuiltinState a -> ByteString) -> SomeBuiltinState a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (SomeBuiltinState a -> [ByteString])
-> SomeBuiltinState a
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.toChunks (ByteString -> [ByteString])
-> (SomeBuiltinState a -> ByteString)
-> SomeBuiltinState a
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractResponse Value Value PABResp PABReq -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ContractResponse Value Value PABResp PABReq -> ByteString)
-> (SomeBuiltinState a
    -> ContractResponse Value Value PABResp PABReq)
-> SomeBuiltinState a
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeBuiltinState a -> ContractResponse Value Value PABResp PABReq
forall a.
SomeBuiltinState a -> ContractResponse Value Value PABResp PABReq
getResponse
    in do
        forall dbt (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlUpdate dbt table -> Eff effs ()
forall (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlUpdate dbt table -> Eff effs ()
updateRows @dbt
          (SqlUpdate dbt ContractInstanceT -> Eff effs ())
-> SqlUpdate dbt ContractInstanceT -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> (forall s. ContractInstanceT (QField s) -> QAssignment dbt s)
-> (forall s. ContractInstanceT (QExpr dbt s) -> QExpr dbt s Bool)
-> SqlUpdate dbt ContractInstanceT
forall be (table :: (* -> *) -> *) (db :: (* -> *) -> *).
(BeamSqlBackend be, Beamable table) =>
DatabaseEntity be db (TableEntity table)
-> (forall s. table (QField s) -> QAssignment be s)
-> (forall s. table (QExpr be s) -> QExpr be s Bool)
-> SqlUpdate be table
update (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
              (\ContractInstanceT (QField s)
ci -> ContractInstanceT (QField s)
ci ContractInstanceT (QField s)
-> Getting
     (QField s (Maybe Text))
     (ContractInstanceT (QField s))
     (QField s (Maybe Text))
-> QField s (Maybe Text)
forall s a. s -> Getting a s a -> a
^. Getting
  (QField s (Maybe Text))
  (ContractInstanceT (QField s))
  (QField s (Maybe Text))
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 (Maybe Text) -> f2 (Columnar f1 (Maybe Text)))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceState QField s (Maybe Text)
-> QExpr dbt s (Maybe Text) -> QAssignment dbt s
forall be s lhs rhs.
SqlUpdatable be s lhs rhs =>
lhs -> rhs -> QAssignment be s
<-. HaskellLiteralForQExpr (QExpr dbt s (Maybe Text))
-> QExpr dbt s (Maybe Text)
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ SomeBuiltinState a -> Text
forall a. SomeBuiltinState a -> Text
encode' State (Builtin a)
SomeBuiltinState a
state))
              (\ContractInstanceT (QExpr dbt s)
ci -> ContractInstanceT (QExpr dbt s)
ci ContractInstanceT (QExpr dbt s)
-> Getting
     (QGenExpr QValueContext dbt s Text)
     (ContractInstanceT (QExpr dbt s))
     (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall s a. s -> Getting a s a -> a
^. Getting
  (QGenExpr QValueContext dbt s Text)
  (ContractInstanceT (QExpr dbt s))
  (QGenExpr QValueContext dbt s Text)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Text -> f2 (Columnar f1 Text))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceId QGenExpr QValueContext dbt s Text
-> QGenExpr QValueContext dbt s Text -> QExpr dbt s Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (ContractInstanceId -> Text
uuidStr ContractInstanceId
instanceId))

  GetState ContractInstanceId
instanceId -> do
    let decodeText :: Text -> Maybe (ContractResponse Value Value PABResp PABReq)
decodeText = ByteString -> Maybe (ContractResponse Value Value PABResp PABReq)
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe (ContractResponse Value Value PABResp PABReq))
-> (Text -> ByteString)
-> Text
-> Maybe (ContractResponse Value Value PABResp PABReq)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> (Text -> Builder) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodeUtf8Builder
        extractState :: Maybe ContractInstance -> Eff effs (SomeBuiltinState a)
extractState = \case
          Maybe ContractInstance
Nothing -> PABError -> Eff effs (SomeBuiltinState a)
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (PABError -> Eff effs (SomeBuiltinState a))
-> PABError -> Eff effs (SomeBuiltinState a)
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> PABError
ContractInstanceNotFound ContractInstanceId
instanceId
          Just  ContractInstance
c ->
            do
              let a :: Columnar Identity Text
a = ContractInstance -> Columnar Identity Text
forall (f :: * -> *). ContractInstanceT f -> Columnar f Text
_contractInstanceContractId ContractInstance
c
                  ty :: Text
ty = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

              a
caID <- Eff effs a -> (a -> Eff effs a) -> Maybe a -> Eff effs a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PABError -> Eff effs a
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (PABError -> Eff effs a) -> PABError -> Eff effs a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PABError
AesonDecodingError (Text
"Couldn't JSON decode this as Type `a`: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ty) Text
Columnar Identity Text
a)
                        a -> Eff effs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe a) -> (Text -> ByteString) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> (Text -> Builder) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodeUtf8Builder (Text -> Maybe a) -> Text -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text
Columnar Identity Text
a)

              ContractResponse Value Value PABResp PABReq
resp <- Eff effs (ContractResponse Value Value PABResp PABReq)
-> (ContractResponse Value Value PABResp PABReq
    -> Eff effs (ContractResponse Value Value PABResp PABReq))
-> Maybe (ContractResponse Value Value PABResp PABReq)
-> Eff effs (ContractResponse Value Value PABResp PABReq)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PABError -> Eff effs (ContractResponse Value Value PABResp PABReq)
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (PABError
 -> Eff effs (ContractResponse Value Value PABResp PABReq))
-> PABError
-> Eff effs (ContractResponse Value Value PABResp PABReq)
forall a b. (a -> b) -> a -> b
$ ContractInstanceId -> PABError
ContractStateNotFound ContractInstanceId
instanceId)
                        ContractResponse Value Value PABResp PABReq
-> Eff effs (ContractResponse Value Value PABResp PABReq)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        (ContractInstance -> Columnar Identity (Maybe Text)
forall (f :: * -> *).
ContractInstanceT f -> Columnar f (Maybe Text)
_contractInstanceState ContractInstance
c Maybe Text
-> (Text -> Maybe (ContractResponse Value Value PABResp PABReq))
-> Maybe (ContractResponse Value Value PABResp PABReq)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (ContractResponse Value Value PABResp PABReq)
decodeText)

              let cd :: SomeBuiltin
cd = a -> SomeBuiltin
forall a. HasDefinitions a => a -> SomeBuiltin
getContract @a a
caID
              ContractInstanceId
-> SomeBuiltin
-> ContractResponse Value Value PABResp PABReq
-> Eff effs (SomeBuiltinState a)
forall a (effs :: [* -> *]).
(Member (LogMsg (PABMultiAgentMsg (Builtin a))) effs,
 Member (Error PABError) effs) =>
ContractInstanceId
-> SomeBuiltin
-> ContractResponse Value Value PABResp PABReq
-> Eff effs (SomeBuiltinState a)
fromResponse @a ContractInstanceId
instanceId SomeBuiltin
cd ContractResponse Value Value PABResp PABReq
resp

    Eff effs (Eff effs (SomeBuiltinState a))
-> Eff effs (SomeBuiltinState a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      (Eff effs (Eff effs (SomeBuiltinState a))
 -> Eff effs (SomeBuiltinState a))
-> Eff effs (Eff effs (SomeBuiltinState a))
-> Eff effs (SomeBuiltinState a)
forall a b. (a -> b) -> a -> b
$ (Maybe ContractInstance -> Eff effs (SomeBuiltinState a))
-> Eff effs (Maybe ContractInstance)
-> Eff effs (Eff effs (SomeBuiltinState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ContractInstance -> Eff effs (SomeBuiltinState a)
extractState
      (Eff effs (Maybe ContractInstance)
 -> Eff effs (Eff effs (SomeBuiltinState a)))
-> Eff effs (Maybe ContractInstance)
-> Eff effs (Eff effs (SomeBuiltinState a))
forall a b. (a -> b) -> a -> b
$ forall a (effs :: [* -> *]).
(FromBackendRow dbt a, Member (BeamEffect dbt) effs) =>
SqlSelect dbt a -> Eff effs (Maybe a)
forall dbt a (effs :: [* -> *]).
(FromBackendRow dbt a, Member (BeamEffect dbt) effs) =>
SqlSelect dbt a -> Eff effs (Maybe a)
selectOne @dbt
      (SqlSelect dbt ContractInstance
 -> Eff effs (Maybe ContractInstance))
-> SqlSelect dbt ContractInstance
-> Eff effs (Maybe ContractInstance)
forall a b. (a -> b) -> a -> b
$ Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
-> SqlSelect
     dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope)))
forall be (db :: (* -> *) -> *) res.
(BeamSqlBackend be, HasQBuilder be, Projectible be res) =>
Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res)
select
      (Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
 -> SqlSelect
      dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope))))
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
-> SqlSelect
     dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope)))
forall a b. (a -> b) -> a -> b
$ do
          ContractInstanceT (QExpr dbt QBaseScope)
inst <- DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
forall be (db :: (* -> *) -> *) (table :: (* -> *) -> *) s.
(Database be db, BeamSqlBackend be) =>
DatabaseEntity be db (TableEntity table)
-> Q be db s (table (QExpr be s))
all_ (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
          QExpr dbt QBaseScope Bool -> Q dbt Db QBaseScope ()
forall be (db :: (* -> *) -> *) s.
BeamSqlBackend be =>
QExpr be s Bool -> Q be db s ()
guard_ (ContractInstanceT (QExpr dbt QBaseScope)
inst ContractInstanceT (QExpr dbt QBaseScope)
-> Getting
     (QGenExpr QValueContext dbt QBaseScope Text)
     (ContractInstanceT (QExpr dbt QBaseScope))
     (QGenExpr QValueContext dbt QBaseScope Text)
-> QGenExpr QValueContext dbt QBaseScope Text
forall s a. s -> Getting a s a -> a
^. Getting
  (QGenExpr QValueContext dbt QBaseScope Text)
  (ContractInstanceT (QExpr dbt QBaseScope))
  (QGenExpr QValueContext dbt QBaseScope Text)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Text -> f2 (Columnar f1 Text))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceId QGenExpr QValueContext dbt QBaseScope Text
-> QGenExpr QValueContext dbt QBaseScope Text
-> QExpr dbt QBaseScope Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QGenExpr QValueContext dbt QBaseScope Text)
-> QGenExpr QValueContext dbt QBaseScope Text
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (ContractInstanceId -> Text
uuidStr ContractInstanceId
instanceId))
          ContractInstanceT (QExpr dbt QBaseScope)
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractInstanceT (QExpr dbt QBaseScope)
inst

  PutStopInstance ContractInstanceId
instanceId ->
    forall dbt (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlUpdate dbt table -> Eff effs ()
forall (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlUpdate dbt table -> Eff effs ()
updateRows @dbt
      (SqlUpdate dbt ContractInstanceT -> Eff effs ())
-> SqlUpdate dbt ContractInstanceT -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> (forall s. ContractInstanceT (QField s) -> QAssignment dbt s)
-> (forall s. ContractInstanceT (QExpr dbt s) -> QExpr dbt s Bool)
-> SqlUpdate dbt ContractInstanceT
forall be (table :: (* -> *) -> *) (db :: (* -> *) -> *).
(BeamSqlBackend be, Beamable table) =>
DatabaseEntity be db (TableEntity table)
-> (forall s. table (QField s) -> QAssignment be s)
-> (forall s. table (QExpr be s) -> QExpr be s Bool)
-> SqlUpdate be table
update (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
          (\ContractInstanceT (QField s)
ci -> ContractInstanceT (QField s)
ci ContractInstanceT (QField s)
-> Getting
     (QField s Bool) (ContractInstanceT (QField s)) (QField s Bool)
-> QField s Bool
forall s a. s -> Getting a s a -> a
^. Getting
  (QField s Bool) (ContractInstanceT (QField s)) (QField s Bool)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Bool -> f2 (Columnar f1 Bool))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceActive QField s Bool -> QExpr dbt s Bool -> QAssignment dbt s
forall be s lhs rhs.
SqlUpdatable be s lhs rhs =>
lhs -> rhs -> QAssignment be s
<-. HaskellLiteralForQExpr (QExpr dbt s Bool) -> QExpr dbt s Bool
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ Bool
HaskellLiteralForQExpr (QExpr dbt s Bool)
False)
          (\ContractInstanceT (QExpr dbt s)
ci -> ContractInstanceT (QExpr dbt s)
ci ContractInstanceT (QExpr dbt s)
-> Getting
     (QGenExpr QValueContext dbt s Text)
     (ContractInstanceT (QExpr dbt s))
     (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall s a. s -> Getting a s a -> a
^. Getting
  (QGenExpr QValueContext dbt s Text)
  (ContractInstanceT (QExpr dbt s))
  (QGenExpr QValueContext dbt s Text)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Text -> f2 (Columnar f1 Text))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceId QGenExpr QValueContext dbt s Text
-> QGenExpr QValueContext dbt s Text -> QExpr dbt s Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (ContractInstanceId -> Text
uuidStr ContractInstanceId
instanceId))

  GetContracts Maybe ContractActivityStatus
mStatus ->
    ([ContractInstance] -> x)
-> Eff effs [ContractInstance] -> Eff effs x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ContractInstance] -> x
forall a.
FromJSON a =>
[ContractInstance]
-> Map
     ContractInstanceId
     (ContractActivationArgs (ContractDef (Builtin a)))
mkContracts
      (Eff effs [ContractInstance] -> Eff effs x)
-> Eff effs [ContractInstance] -> Eff effs x
forall a b. (a -> b) -> a -> b
$ forall a (effs :: [* -> *]).
(FromBackendRow dbt a, Member (BeamEffect dbt) effs) =>
SqlSelect dbt a -> Eff effs [a]
forall dbt a (effs :: [* -> *]).
(FromBackendRow dbt a, Member (BeamEffect dbt) effs) =>
SqlSelect dbt a -> Eff effs [a]
selectList @dbt
      (SqlSelect dbt ContractInstance -> Eff effs [ContractInstance])
-> SqlSelect dbt ContractInstance -> Eff effs [ContractInstance]
forall a b. (a -> b) -> a -> b
$ Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
-> SqlSelect
     dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope)))
forall be (db :: (* -> *) -> *) res.
(BeamSqlBackend be, HasQBuilder be, Projectible be res) =>
Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res)
select
      (Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
 -> SqlSelect
      dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope))))
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
-> SqlSelect
     dbt (QExprToIdentity (ContractInstanceT (QExpr dbt QBaseScope)))
forall a b. (a -> b) -> a -> b
$ do
          ContractInstanceT (QExpr dbt QBaseScope)
ci <- DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
forall be (db :: (* -> *) -> *) (table :: (* -> *) -> *) s.
(Database be db, BeamSqlBackend be) =>
DatabaseEntity be db (TableEntity table)
-> Q be db s (table (QExpr be s))
all_ (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
          case Maybe ContractActivityStatus
mStatus of
            Just ContractActivityStatus
s -> QExpr dbt QBaseScope Bool -> Q dbt Db QBaseScope ()
forall be (db :: (* -> *) -> *) s.
BeamSqlBackend be =>
QExpr be s Bool -> Q be db s ()
guard_ ( ContractInstanceT (QExpr dbt QBaseScope)
ci ContractInstanceT (QExpr dbt QBaseScope)
-> Getting
     (QExpr dbt QBaseScope Bool)
     (ContractInstanceT (QExpr dbt QBaseScope))
     (QExpr dbt QBaseScope Bool)
-> QExpr dbt QBaseScope Bool
forall s a. s -> Getting a s a -> a
^. Getting
  (QExpr dbt QBaseScope Bool)
  (ContractInstanceT (QExpr dbt QBaseScope))
  (QExpr dbt QBaseScope Bool)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Bool -> f2 (Columnar f1 Bool))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceActive QExpr dbt QBaseScope Bool
-> QExpr dbt QBaseScope Bool -> QExpr dbt QBaseScope Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QExpr dbt QBaseScope Bool)
-> QExpr dbt QBaseScope Bool
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (ContractActivityStatus
s ContractActivityStatus -> ContractActivityStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ContractActivityStatus
Active) )
            Maybe ContractActivityStatus
_      -> () -> Q dbt Db QBaseScope ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ContractInstanceT (QExpr dbt QBaseScope)
-> Q dbt Db QBaseScope (ContractInstanceT (QExpr dbt QBaseScope))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractInstanceT (QExpr dbt QBaseScope)
ci

  DeleteState ContractInstanceId
instanceId ->
    forall dbt (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlDelete dbt table -> Eff effs ()
forall (table :: (* -> *) -> *) (effs :: [* -> *]).
(Beamable table, Member (BeamEffect dbt) effs) =>
SqlDelete dbt table -> Eff effs ()
deleteRows @dbt
      (SqlDelete dbt ContractInstanceT -> Eff effs ())
-> SqlDelete dbt ContractInstanceT -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ DatabaseEntity dbt Db (TableEntity ContractInstanceT)
-> (forall s.
    (forall s'. ContractInstanceT (QExpr dbt s')) -> QExpr dbt s Bool)
-> SqlDelete dbt ContractInstanceT
forall be (db :: (* -> *) -> *) (table :: (* -> *) -> *).
BeamSqlBackend be =>
DatabaseEntity be db (TableEntity table)
-> (forall s. (forall s'. table (QExpr be s')) -> QExpr be s Bool)
-> SqlDelete be table
delete
          (Db (DatabaseEntity dbt Db)
-> DatabaseEntity dbt Db (TableEntity ContractInstanceT)
forall (f :: * -> *). Db f -> f (TableEntity ContractInstanceT)
_contractInstances Db (DatabaseEntity dbt Db)
forall be. DatabaseSettings be Db
db)
          (\forall s'. ContractInstanceT (QExpr dbt s')
ci -> ContractInstanceT (QExpr dbt s)
forall s'. ContractInstanceT (QExpr dbt s')
ci ContractInstanceT (QExpr dbt s)
-> Getting
     (QGenExpr QValueContext dbt s Text)
     (ContractInstanceT (QExpr dbt s))
     (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall s a. s -> Getting a s a -> a
^. Getting
  (QGenExpr QValueContext dbt s Text)
  (ContractInstanceT (QExpr dbt s))
  (QGenExpr QValueContext dbt s Text)
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(Columnar f1 Text -> f2 (Columnar f1 Text))
-> ContractInstanceT f1 -> f2 (ContractInstanceT f1)
contractInstanceId QGenExpr QValueContext dbt s Text
-> QGenExpr QValueContext dbt s Text -> QExpr dbt s Bool
forall (expr :: * -> *) a. SqlEq expr a => a -> a -> expr Bool
==. HaskellLiteralForQExpr (QGenExpr QValueContext dbt s Text)
-> QGenExpr QValueContext dbt s Text
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ (ContractInstanceId -> Text
uuidStr ContractInstanceId
instanceId))