From 9b90de9fd61b956d198c991030507ac95ca2ca5f Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 4 Apr 2023 08:58:30 -0400 Subject: [PATCH] Rename Marlowe protocol -> MarloweRuntime --- .../src/Language/Marlowe/Runtime/App/Types.hs | 4 +- .../src/Control/Monad/Trans/Marlowe.hs | 6 +-- .../src/Control/Monad/Trans/Marlowe/Class.hs | 26 ++++++------ .../src/Language/Marlowe/Runtime/Client.hs | 4 +- .../src/Test/Integration/Marlowe/Local.hs | 28 ++++++------- .../app/Language/Marlowe/Runtime/CLI/Monad.hs | 4 +- .../Language/Marlowe/Runtime/Web/Server.hs | 4 +- .../Marlowe/Runtime/Web/Server/SyncClient.hs | 4 +- .../Marlowe/Runtime/Web/Server/TxClient.hs | 4 +- marlowe-runtime/marlowe-proxy/Logging.hs | 8 ++-- marlowe-runtime/marlowe-proxy/Main.hs | 6 +-- .../Language/Marlowe/Protocol/Client.hs | 18 ++++----- .../Language/Marlowe/Protocol/Server.hs | 22 +++++----- .../Language/Marlowe/Protocol/Types.hs | 40 +++++++++---------- .../proxy/Language/Marlowe/Runtime/Proxy.hs | 8 ++-- 15 files changed, 93 insertions(+), 93 deletions(-) diff --git a/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs b/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs index 1eb6cc7eb1..b937806919 100644 --- a/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs +++ b/marlowe-apps/src/Language/Marlowe/Runtime/App/Types.hs @@ -88,7 +88,7 @@ import qualified Data.Aeson.Types as A import Data.Foldable (fold) import qualified Data.Map.Strict as M (Map, map, mapKeys) import qualified Data.Text as T (Text) -import Language.Marlowe.Protocol.Client (hoistMarloweClient) +import Language.Marlowe.Protocol.Client (hoistMarloweRuntimeClient) import Language.Marlowe.Protocol.Query.Types (ContractFilter) import qualified Language.Marlowe.Runtime.ChainSync.Api as CS (Transaction) @@ -157,7 +157,7 @@ instance MonadWith Client where restore' = Client . restore . runClient instance MonadMarlowe Client where - runMarloweClient client = Client $ runMarloweClient $ hoistMarloweClient runClient client + runMarloweRuntimeClient client = Client $ runMarloweRuntimeClient $ hoistMarloweRuntimeClient runClient client -- | A function signature for running a client for some protocol in some monad m. diff --git a/marlowe-client/src/Control/Monad/Trans/Marlowe.hs b/marlowe-client/src/Control/Monad/Trans/Marlowe.hs index b69905db8c..333afaef00 100644 --- a/marlowe-client/src/Control/Monad/Trans/Marlowe.hs +++ b/marlowe-client/src/Control/Monad/Trans/Marlowe.hs @@ -25,11 +25,11 @@ import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.With (MonadWith(..)) import Control.Monad.Writer (MonadWriter) import Data.GeneralAllocate (GeneralAllocate(..), GeneralAllocated(..)) -import Language.Marlowe.Protocol.Client (MarloweClient) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient) import Network.Protocol.Connection (SomeClientConnector) import UnliftIO (MonadUnliftIO) -newtype MarloweT m a = MarloweT { unMarloweT :: ReaderT (SomeClientConnector MarloweClient IO) m a } +newtype MarloweT m a = MarloweT { unMarloweT :: ReaderT (SomeClientConnector MarloweRuntimeClient IO) m a } deriving newtype ( Functor , Applicative @@ -84,5 +84,5 @@ instance MonadReader r m => MonadReader r (MarloweT m) where mapMarloweT :: (m a -> n b) -> MarloweT m a -> MarloweT n b mapMarloweT f = MarloweT . mapReaderT f . unMarloweT -runMarloweT :: MarloweT m a -> SomeClientConnector MarloweClient IO -> m a +runMarloweT :: MarloweT m a -> SomeClientConnector MarloweRuntimeClient IO -> m a runMarloweT = runReaderT . unMarloweT diff --git a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs index bae2b6fee2..a792ad1fdc 100644 --- a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs +++ b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs @@ -10,7 +10,7 @@ import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource.Internal (ResourceT(..)) import Data.Coerce (coerce) import Data.Time (UTCTime) -import Language.Marlowe.Protocol.Client (MarloweClient(..), hoistMarloweClient) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient(..), hoistMarloweRuntimeClient) import Language.Marlowe.Protocol.HeaderSync.Client (MarloweHeaderSyncClient) import Language.Marlowe.Protocol.Query.Client (MarloweQueryClient) import Language.Marlowe.Protocol.Sync.Client (MarloweSyncClient) @@ -38,40 +38,40 @@ import UnliftIO (MonadIO, MonadUnliftIO, liftIO, newIORef, readIORef, withRunInI -- Runtime instance. class Monad m => MonadMarlowe m where -- ^ Run a client of the Marlowe protocol. - runMarloweClient :: MarloweClient m a -> m a + runMarloweRuntimeClient :: MarloweRuntimeClient m a -> m a instance MonadUnliftIO m => MonadMarlowe (MarloweT m) where - runMarloweClient client = MarloweT $ ReaderT \connector -> withRunInIO \runInIO -> - runSomeConnector connector $ hoistMarloweClient (runInIO . flip runMarloweT connector) client + runMarloweRuntimeClient client = MarloweT $ ReaderT \connector -> withRunInIO \runInIO -> + runSomeConnector connector $ hoistMarloweRuntimeClient (runInIO . flip runMarloweT connector) client instance MonadMarlowe m => MonadMarlowe (ReaderT r m) where - runMarloweClient client = ReaderT \r -> - runMarloweClient $ hoistMarloweClient (flip runReaderT r) client + runMarloweRuntimeClient client = ReaderT \r -> + runMarloweRuntimeClient $ hoistMarloweRuntimeClient (flip runReaderT r) client instance MonadMarlowe m => MonadMarlowe (ResourceT m) where - runMarloweClient client = ResourceT \rm -> - runMarloweClient $ hoistMarloweClient (flip unResourceT rm) client + runMarloweRuntimeClient client = ResourceT \rm -> + runMarloweRuntimeClient $ hoistMarloweRuntimeClient (flip unResourceT rm) client instance MonadMarlowe m => MonadMarlowe (IdentityT m) where - runMarloweClient = coerce runMarloweClient + runMarloweRuntimeClient = coerce runMarloweRuntimeClient -- ^ Run a MarloweSyncClient. Used to synchronize with history for a specific -- contract. runMarloweSyncClient :: MonadMarlowe m => MarloweSyncClient m a -> m a -runMarloweSyncClient = runMarloweClient . RunMarloweSyncClient +runMarloweSyncClient = runMarloweRuntimeClient . RunMarloweSyncClient -- ^ Run a MarloweHeaderSyncClient. Used to synchronize with contract creation -- transactions. runMarloweHeaderSyncClient :: MonadMarlowe m => MarloweHeaderSyncClient m a -> m a -runMarloweHeaderSyncClient = runMarloweClient . RunMarloweHeaderSyncClient +runMarloweHeaderSyncClient = runMarloweRuntimeClient . RunMarloweHeaderSyncClient -- ^ Run a MarloweQueryClient. runMarloweQueryClient :: MonadMarlowe m => MarloweQueryClient m a -> m a -runMarloweQueryClient = runMarloweClient . RunMarloweQueryClient +runMarloweQueryClient = runMarloweRuntimeClient . RunMarloweQueryClient -- ^ Run a MarloweTxCommand job client. runMarloweTxClient :: MonadMarlowe m => JobClient MarloweTxCommand m a -> m a -runMarloweTxClient = runMarloweClient . RunTxClient +runMarloweTxClient = runMarloweRuntimeClient . RunTxClient -- ^ Create a new contract. createContract diff --git a/marlowe-client/src/Language/Marlowe/Runtime/Client.hs b/marlowe-client/src/Language/Marlowe/Runtime/Client.hs index be697ec279..c404fa7a9e 100644 --- a/marlowe-client/src/Language/Marlowe/Runtime/Client.hs +++ b/marlowe-client/src/Language/Marlowe/Runtime/Client.hs @@ -6,7 +6,7 @@ module Language.Marlowe.Runtime.Client import Control.Monad.Trans.Marlowe import Control.Monad.Trans.Marlowe.Class -import Language.Marlowe.Protocol.Client (marloweClientPeer) +import Language.Marlowe.Protocol.Client (marloweRuntimeClientPeer) import Network.Protocol.Connection (SomeConnector(..)) import Network.Protocol.Driver (tcpClient) import Network.Protocol.Handshake.Client (handshakeClientConnector) @@ -16,4 +16,4 @@ connectToMarloweRuntime :: HostName -> PortNumber -> MarloweT m a -> m a connectToMarloweRuntime host port action = runMarloweT action $ SomeConnector $ handshakeClientConnector - $ tcpClient host port marloweClientPeer + $ tcpClient host port marloweRuntimeClientPeer diff --git a/marlowe-integration/src/Test/Integration/Marlowe/Local.hs b/marlowe-integration/src/Test/Integration/Marlowe/Local.hs index 058951a631..c3d18228ef 100644 --- a/marlowe-integration/src/Test/Integration/Marlowe/Local.hs +++ b/marlowe-integration/src/Test/Integration/Marlowe/Local.hs @@ -88,18 +88,18 @@ import Language.Marlowe.CLI.Types , ValidatorInfo(..) , defaultCoinSelectionStrategy ) -import Language.Marlowe.Protocol.Client (MarloweClient, hoistMarloweClient, marloweClientPeer) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient, hoistMarloweRuntimeClient, marloweRuntimeClientPeer) import Language.Marlowe.Protocol.HeaderSync.Client (MarloweHeaderSyncClient, marloweHeaderSyncClientPeer) import Language.Marlowe.Protocol.HeaderSync.Server (MarloweHeaderSyncServer, marloweHeaderSyncServerPeer) import Language.Marlowe.Protocol.HeaderSync.Types (MarloweHeaderSync) import Language.Marlowe.Protocol.Query.Client (MarloweQueryClient(..), marloweQueryClientPeer) import Language.Marlowe.Protocol.Query.Server (MarloweQueryServer) import Language.Marlowe.Protocol.Query.Types (MarloweQuery) -import Language.Marlowe.Protocol.Server (MarloweServer, marloweServerPeer) +import Language.Marlowe.Protocol.Server (MarloweRuntimeServer, marloweRuntimeServerPeer) import Language.Marlowe.Protocol.Sync.Client (MarloweSyncClient, marloweSyncClientPeer) import Language.Marlowe.Protocol.Sync.Server (MarloweSyncServer, marloweSyncServerPeer) import Language.Marlowe.Protocol.Sync.Types (MarloweSync) -import Language.Marlowe.Protocol.Types (Marlowe) +import qualified Language.Marlowe.Protocol.Types as Protocol import Language.Marlowe.Runtime.Cardano.Api (fromCardanoAddressInEra, fromCardanoLovelace, fromCardanoTxId) import Language.Marlowe.Runtime.ChainIndexer (ChainIndexerDependencies(..), ChainIndexerSelector, chainIndexer, getChainIndexerSelectorConfig) @@ -180,7 +180,7 @@ import Text.Read (readMaybe) import UnliftIO (MonadUnliftIO, withRunInIO) data MarloweRuntime = MarloweRuntime - { protocolConnector :: SomeClientConnector MarloweClient IO + { protocolConnector :: SomeClientConnector MarloweRuntimeClient IO , proxyPort :: Int , runWebClient :: forall a. ClientM a -> IO (Either ClientError a) , marloweScripts :: MarloweScripts @@ -299,7 +299,7 @@ withLocalMarloweRuntime' MarloweRuntimeOptions{..} test = withRunInIO \runInIO - else liftIO $ threadDelay 1000 *> waitForWebServer (counter + 1) | otherwise = fail "Unable to connect to web server" - let protocolConnector = SomeConnector $ ihoistConnector hoistMarloweClient (runResourceT . runWrappedUnliftIO) liftIO $ clientConnector marlowePair + let protocolConnector = SomeConnector $ ihoistConnector hoistMarloweRuntimeClient (runResourceT . runWrappedUnliftIO) liftIO $ clientConnector marlowePair -- Persist the genesis block before starting the services so that they -- exist already and no database queries fail. @@ -451,9 +451,9 @@ data RuntimeSelector f where HeaderSyncPair :: ClientServerPairSelector (Handshake MarloweHeaderSync) f -> RuntimeSelector f MarloweSyncPair :: ClientServerPairSelector (Handshake MarloweSync) f -> RuntimeSelector f MarloweQueryPair :: ClientServerPairSelector (Handshake MarloweQuery) f -> RuntimeSelector f - MarlowePair :: ClientServerPairSelector (Handshake Marlowe) f -> RuntimeSelector f + MarlowePair :: ClientServerPairSelector (Handshake Protocol.MarloweRuntime) f -> RuntimeSelector f TxJobPair :: ClientServerPairSelector (Handshake (Job MarloweTxCommand)) f -> RuntimeSelector f - MarloweTCP :: ConnectorSelector (Handshake Marlowe) f -> RuntimeSelector f + MarloweTCP :: ConnectorSelector (Handshake Protocol.MarloweRuntime) f -> RuntimeSelector f TxEvent :: TransactionServerSelector f -> RuntimeSelector f ChainIndexerEvent :: ChainIndexerSelector f -> RuntimeSelector f MarloweIndexerEvent :: MarloweIndexerSelector f -> RuntimeSelector f @@ -466,7 +466,7 @@ data RuntimeDependencies r = RuntimeDependencies , chainSyncQueryPair :: ClientServerPair (Handshake (Query ChainSyncQuery)) (QueryServer ChainSyncQuery) (QueryClient ChainSyncQuery) IO , marloweHeaderSyncPair :: ClientServerPair (Handshake MarloweHeaderSync) MarloweHeaderSyncServer MarloweHeaderSyncClient IO , marloweSyncPair :: ClientServerPair (Handshake MarloweSync) MarloweSyncServer MarloweSyncClient IO - , marlowePair :: ClientServerPair (Handshake Marlowe) MarloweServer MarloweClient ServerM + , marlowePair :: ClientServerPair (Handshake Protocol.MarloweRuntime) MarloweRuntimeServer MarloweRuntimeClient ServerM , marloweQueryPair :: ClientServerPair (Handshake MarloweQuery) MarloweQueryServer MarloweQueryClient IO , txJobPair :: ClientServerPair (Handshake (Job MarloweTxCommand)) (JobServer MarloweTxCommand) (JobClient MarloweTxCommand) IO , chainIndexerDatabaseQueries :: ChainIndexer.DatabaseQueries IO @@ -494,7 +494,7 @@ runtime = proc RuntimeDependencies{..} -> do LocalNodeConnectInfo{..} = localNodeConnectInfo - marloweServerSource <- handshakeConnectionSource <$> tcpServer -< TcpServerDependencies "127.0.0.1" (fromIntegral proxyPort) marloweServerPeer + marloweRuntimeServerSource <- handshakeConnectionSource <$> tcpServer -< TcpServerDependencies "127.0.0.1" (fromIntegral proxyPort) marloweRuntimeServerPeer chainIndexer -< let @@ -583,7 +583,7 @@ runtime = proc RuntimeDependencies{..} -> do , getMarloweHeaderSyncDriver = driverFactory $ clientConnector marloweHeaderSyncPair , getMarloweQueryDriver = driverFactory $ clientConnector marloweQueryPair , getTxJobDriver = driverFactory $ clientConnector txJobPair - , connectionSource = SomeConnectionSource (logConnectionSource (narrowEventBackend (injectSelector MarloweTCP) $ hoistEventBackend liftIO rootEventBackend) marloweServerSource <> Connection.connectionSource marlowePair) + , connectionSource = SomeConnectionSource (logConnectionSource (narrowEventBackend (injectSelector MarloweTCP) $ hoistEventBackend liftIO rootEventBackend) marloweRuntimeServerSource <> Connection.connectionSource marlowePair) , httpPort = webPort + 6 } @@ -591,7 +591,7 @@ runtime = proc RuntimeDependencies{..} -> do { openAPIEnabled = False , accessControlAllowOriginAll = False , runApplication = run webPort - , connector = SomeConnector $ ihoistConnector hoistMarloweClient (runResourceT . runWrappedUnliftIO) liftIO $ clientConnector marlowePair + , connector = SomeConnector $ ihoistConnector hoistMarloweRuntimeClient (runResourceT . runWrappedUnliftIO) liftIO $ clientConnector marlowePair , eventBackend = noopEventBackend () } @@ -608,7 +608,7 @@ data Channels = Channels , marloweSyncPair :: ClientServerPair (Handshake MarloweSync) MarloweSyncServer MarloweSyncClient IO , marloweQueryPair :: ClientServerPair (Handshake MarloweQuery) MarloweQueryServer MarloweQueryClient IO , txJobPair :: ClientServerPair (Handshake (Job MarloweTxCommand)) (JobServer MarloweTxCommand) (JobClient MarloweTxCommand) IO - , marlowePair :: ClientServerPair (Handshake Marlowe) MarloweServer MarloweClient ServerM + , marlowePair :: ClientServerPair (Handshake Protocol.MarloweRuntime) MarloweRuntimeServer MarloweRuntimeClient ServerM } setupChannels :: EventBackend IO r RuntimeSelector -> STM Channels @@ -635,8 +635,8 @@ setupChannels eventBackend = do jobServerPeer jobClientPeer marlowePair <- logClientServerPair (hoistEventBackend liftIO $ narrowEventBackend (injectSelector MarlowePair) eventBackend) . handshakeClientServerPair <$> clientServerPair - marloweServerPeer - marloweClientPeer + marloweRuntimeServerPeer + marloweRuntimeClientPeer pure Channels{..} getRuntimeSelectorConfig :: RuntimeSelector f -> SelectorConfig f diff --git a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs index c26a231e3e..f8daab9cf6 100644 --- a/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs +++ b/marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Monad.hs @@ -13,7 +13,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Marlowe (MarloweT) import Control.Monad.Trans.Marlowe.Class (MonadMarlowe(..)) import Control.Monad.Trans.Reader (ReaderT) -import Language.Marlowe.Protocol.Client (hoistMarloweClient) +import Language.Marlowe.Protocol.Client (hoistMarloweRuntimeClient) import Language.Marlowe.Runtime.CLI.Env (Env(..)) import Options.Applicative (Alternative) import System.Exit (die) @@ -34,7 +34,7 @@ newtype CLI a = CLI { runCLI :: MarloweT (ReaderT Env IO) a } ) instance MonadMarlowe CLI where - runMarloweClient client = CLI $ runMarloweClient $ hoistMarloweClient runCLI client + runMarloweRuntimeClient client = CLI $ runMarloweRuntimeClient $ hoistMarloweRuntimeClient runCLI client -- | Get the environment. askEnv :: CLI Env diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs index bd1562ed66..2b6fcf9c02 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs @@ -27,7 +27,7 @@ import Control.Concurrent.Component import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.Reader (runReaderT) import Data.Void (Void) -import Language.Marlowe.Protocol.Client (MarloweClient) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient) import qualified Language.Marlowe.Runtime.Web as Web import Language.Marlowe.Runtime.Web.Server.Monad (AppEnv(..), AppM(..)) import qualified Language.Marlowe.Runtime.Web.Server.OpenAPI as OpenAPI @@ -108,7 +108,7 @@ data ServerDependencies r = ServerDependencies { openAPIEnabled :: Bool , accessControlAllowOriginAll :: Bool , runApplication :: Application -> IO () - , connector :: SomeClientConnector MarloweClient IO + , connector :: SomeClientConnector MarloweRuntimeClient IO , eventBackend :: EventBackend IO r ServerSelector } diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs index 06f7680ae7..c1b9468d70 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs @@ -12,7 +12,7 @@ import Control.Error (note) import Control.Monad (guard, mfilter) import Control.Monad.IO.Class (liftIO) import Data.List (uncons) -import Language.Marlowe.Protocol.Client (MarloweClient(..)) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient(..)) import Language.Marlowe.Protocol.Query.Client (getContractHeaders, getContractState, getTransaction, getTransactions, getWithdrawal, getWithdrawals) import Language.Marlowe.Protocol.Query.Types @@ -29,7 +29,7 @@ import Network.Protocol.Driver (runSomeConnector) import Servant.Pagination data SyncClientDependencies = SyncClientDependencies - { connector :: SomeClientConnector MarloweClient IO + { connector :: SomeClientConnector MarloweRuntimeClient IO , lookupTempContract :: ContractId -> STM (Maybe (TempTx ContractCreated)) , lookupTempTransaction :: ContractId -> TxId -> STM (Maybe (TempTx InputsApplied)) , lookupTempWithdrawal :: TxId -> STM (Maybe (TempTx Withdrawn)) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs index 8e834cc958..e1f8f52f15 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs @@ -32,7 +32,7 @@ import Data.Foldable (for_) import qualified Data.Map as Map import Data.Time (UTCTime) import Data.Void (Void) -import Language.Marlowe.Protocol.Client (MarloweClient(..)) +import Language.Marlowe.Protocol.Client (MarloweRuntimeClient(..)) import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) import Language.Marlowe.Runtime.ChainSync.Api (Lovelace, StakeCredential, TokenName, TxId) import Language.Marlowe.Runtime.Core.Api @@ -65,7 +65,7 @@ compile $ SelectorSpec ["tx", "client"] ] newtype TxClientDependencies r = TxClientDependencies - { connector :: SomeClientConnector MarloweClient IO + { connector :: SomeClientConnector MarloweRuntimeClient IO } type CreateContract m diff --git a/marlowe-runtime/marlowe-proxy/Logging.hs b/marlowe-runtime/marlowe-proxy/Logging.hs index af77d729d4..c7c6ee422d 100644 --- a/marlowe-runtime/marlowe-proxy/Logging.hs +++ b/marlowe-runtime/marlowe-proxy/Logging.hs @@ -9,7 +9,7 @@ module Logging import Data.Foldable (fold) import Data.Map (Map) import Data.Text (Text) -import Language.Marlowe.Protocol.Types (Marlowe) +import Language.Marlowe.Protocol.Types (MarloweRuntime) import Network.Protocol.Connection (ConnectorSelector, getConnectorSelectorConfig, getDefaultConnectorLogConfig) import Network.Protocol.Handshake.Types (Handshake) import Observe.Event.Component @@ -23,16 +23,16 @@ import Observe.Event.Component ) data RootSelector f where - MarloweServer :: ConnectorSelector (Handshake Marlowe) f -> RootSelector f + MarloweRuntimeServer :: ConnectorSelector (Handshake MarloweRuntime) f -> RootSelector f ConfigWatcher :: ConfigWatcherSelector f -> RootSelector f getRootSelectorConfig :: GetSelectorConfig RootSelector getRootSelectorConfig = \case - MarloweServer sel -> prependKey "proxy-server" $ getConnectorSelectorConfig False False sel + MarloweRuntimeServer sel -> prependKey "proxy-server" $ getConnectorSelectorConfig False False sel ConfigWatcher ReloadConfig -> SelectorConfig "reload-log-config" True $ singletonFieldConfig "config" True defaultRootSelectorLogConfig :: Map Text SelectorLogConfig defaultRootSelectorLogConfig = fold - [ getDefaultConnectorLogConfig getRootSelectorConfig MarloweServer + [ getDefaultConnectorLogConfig getRootSelectorConfig MarloweRuntimeServer , getDefaultLogConfig getRootSelectorConfig $ ConfigWatcher ReloadConfig ] diff --git a/marlowe-runtime/marlowe-proxy/Main.hs b/marlowe-runtime/marlowe-proxy/Main.hs index b2038322ae..5510af89d0 100644 --- a/marlowe-runtime/marlowe-proxy/Main.hs +++ b/marlowe-runtime/marlowe-proxy/Main.hs @@ -12,7 +12,7 @@ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as TL import Data.UUID.V4 (nextRandom) -import Language.Marlowe.Protocol.Server (marloweServerPeer) +import Language.Marlowe.Protocol.Server (marloweRuntimeServerPeer) import Language.Marlowe.Runtime.CLI.Option (optParserWithEnvDefault) import qualified Language.Marlowe.Runtime.CLI.Option as O import Language.Marlowe.Runtime.Proxy @@ -73,7 +73,7 @@ run = runComponent_ proc Options{..} -> do } connectionSource <- tcpServer -< TcpServerDependencies - { toPeer = marloweServerPeer + { toPeer = marloweRuntimeServerPeer , .. } @@ -83,7 +83,7 @@ run = runComponent_ proc Options{..} -> do , getMarloweQueryDriver = driverFactory syncHost marloweQueryPort , getTxJobDriver = driverFactory txHost txPort , connectionSource = SomeConnectionSource - $ logConnectionSource (hoistEventBackend liftIO $ narrowEventBackend (injectSelector MarloweServer) eventBackend) + $ logConnectionSource (hoistEventBackend liftIO $ narrowEventBackend (injectSelector MarloweRuntimeServer) eventBackend) $ handshakeConnectionSource connectionSource , httpPort = fromIntegral httpPort } diff --git a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Client.hs b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Client.hs index 5311963747..b874fc5341 100644 --- a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Client.hs +++ b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Client.hs @@ -18,22 +18,22 @@ import Network.Protocol.Job.Client (JobClient, hoistJobClient, jobClientPeer) import Network.Protocol.Job.Types (Job) import Network.TypedProtocol (Peer(..), PeerHasAgency(..), PeerRole(..)) -data MarloweClient m a +data MarloweRuntimeClient m a = RunMarloweSyncClient (MarloweSyncClient m a) | RunMarloweHeaderSyncClient (MarloweHeaderSyncClient m a) | RunMarloweQueryClient (MarloweQueryClient m a) | RunTxClient (JobClient MarloweTxCommand m a) deriving Functor -hoistMarloweClient :: Functor m => (forall x. m x -> n x) -> MarloweClient m a -> MarloweClient n a -hoistMarloweClient f = \case +hoistMarloweRuntimeClient :: Functor m => (forall x. m x -> n x) -> MarloweRuntimeClient m a -> MarloweRuntimeClient n a +hoistMarloweRuntimeClient f = \case RunMarloweSyncClient client -> RunMarloweSyncClient $ hoistMarloweSyncClient f client RunMarloweHeaderSyncClient client -> RunMarloweHeaderSyncClient $ hoistMarloweHeaderSyncClient f client RunMarloweQueryClient client -> RunMarloweQueryClient $ hoistMarloweQueryClient f client RunTxClient client -> RunTxClient $ hoistJobClient f client -marloweClientPeer :: Monad m => MarloweClient m a -> Peer Marlowe 'AsClient 'StInit m a -marloweClientPeer = \case +marloweRuntimeClientPeer :: Monad m => MarloweRuntimeClient m a -> Peer MarloweRuntime 'AsClient 'StInit m a +marloweRuntimeClientPeer = \case RunMarloweSyncClient client -> Yield (ClientAgency TokInit) MsgRunMarloweSync $ liftMarloweSyncPeer $ marloweSyncClientPeer client RunMarloweHeaderSyncClient client -> @@ -43,28 +43,28 @@ marloweClientPeer = \case RunTxClient client -> Yield (ClientAgency TokInit) MsgRunTxJob $ liftTxJobPeer $ jobClientPeer client -liftTxJobPeer :: Functor m => Peer (Job MarloweTxCommand) 'AsClient st m a -> Peer Marlowe 'AsClient ('StTxJob st) m a +liftTxJobPeer :: Functor m => Peer (Job MarloweTxCommand) 'AsClient st m a -> Peer MarloweRuntime 'AsClient ('StTxJob st) m a liftTxJobPeer = \case Effect m -> Effect $ liftTxJobPeer <$> m Done tok a -> Done (TokNobodyTxJob tok) a Yield (ClientAgency tok) msg next -> Yield (ClientAgency $ TokClientTxJob tok) (MsgTxJob msg) $ liftTxJobPeer next Await (ServerAgency tok) next -> Await (ServerAgency $ TokServerTxJob tok) \(MsgTxJob msg) -> liftTxJobPeer $ next msg -liftMarloweHeaderSyncPeer :: Functor m => Peer MarloweHeaderSync 'AsClient st m a -> Peer Marlowe 'AsClient ('StMarloweHeaderSync st) m a +liftMarloweHeaderSyncPeer :: Functor m => Peer MarloweHeaderSync 'AsClient st m a -> Peer MarloweRuntime 'AsClient ('StMarloweHeaderSync st) m a liftMarloweHeaderSyncPeer = \case Effect m -> Effect $ liftMarloweHeaderSyncPeer <$> m Done tok a -> Done (TokNobodyMarloweHeaderSync tok) a Yield (ClientAgency tok) msg next -> Yield (ClientAgency $ TokClientMarloweHeaderSync tok) (MsgMarloweHeaderSync msg) $ liftMarloweHeaderSyncPeer next Await (ServerAgency tok) next -> Await (ServerAgency $ TokServerMarloweHeaderSync tok) \(MsgMarloweHeaderSync msg) -> liftMarloweHeaderSyncPeer $ next msg -liftMarloweSyncPeer :: Functor m => Peer MarloweSync 'AsClient st m a -> Peer Marlowe 'AsClient ('StMarloweSync st) m a +liftMarloweSyncPeer :: Functor m => Peer MarloweSync 'AsClient st m a -> Peer MarloweRuntime 'AsClient ('StMarloweSync st) m a liftMarloweSyncPeer = \case Effect m -> Effect $ liftMarloweSyncPeer <$> m Done tok a -> Done (TokNobodyMarloweSync tok) a Yield (ClientAgency tok) msg next -> Yield (ClientAgency $ TokClientMarloweSync tok) (MsgMarloweSync msg) $ liftMarloweSyncPeer next Await (ServerAgency tok) next -> Await (ServerAgency $ TokServerMarloweSync tok) \(MsgMarloweSync msg) -> liftMarloweSyncPeer $ next msg -liftMarloweQueryPeer :: Functor m => Peer MarloweQuery 'AsClient st m a -> Peer Marlowe 'AsClient ('StMarloweQuery st) m a +liftMarloweQueryPeer :: Functor m => Peer MarloweQuery 'AsClient st m a -> Peer MarloweRuntime 'AsClient ('StMarloweQuery st) m a liftMarloweQueryPeer = \case Effect m -> Effect $ liftMarloweQueryPeer <$> m Done tok a -> Done (TokNobodyMarloweQuery tok) a diff --git a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Server.hs b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Server.hs index fd1f18359a..ba0420ae61 100644 --- a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Server.hs +++ b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Server.hs @@ -21,7 +21,7 @@ import Network.Protocol.Job.Types (Job) import qualified Network.Protocol.Job.Types as Job import Network.TypedProtocol -data MarloweServer m a = forall dState. MarloweServer +data MarloweRuntimeServer m a = forall dState. MarloweRuntimeServer { getMarloweSyncDriver :: m (Driver (Handshake MarloweSync) dState m) , getMarloweHeaderSyncDriver :: m (Driver (Handshake MarloweHeaderSync) dState m) , getMarloweQueryDriver :: m (Driver (Handshake MarloweQuery) dState m) @@ -29,8 +29,8 @@ data MarloweServer m a = forall dState. MarloweServer , result :: a } -hoistMarloweServer :: Functor m => (forall x. m x -> n x) -> MarloweServer m a -> MarloweServer n a -hoistMarloweServer f MarloweServer{..} = MarloweServer +hoistMarloweRuntimeServer :: Functor m => (forall x. m x -> n x) -> MarloweRuntimeServer m a -> MarloweRuntimeServer n a +hoistMarloweRuntimeServer f MarloweRuntimeServer{..} = MarloweRuntimeServer { getMarloweSyncDriver = f $ hoistDriver f <$> getMarloweSyncDriver , getMarloweHeaderSyncDriver = f $ hoistDriver f <$> getMarloweHeaderSyncDriver , getMarloweQueryDriver = f $ hoistDriver f <$> getMarloweQueryDriver @@ -38,8 +38,8 @@ hoistMarloweServer f MarloweServer{..} = MarloweServer , .. } -marloweServerPeer :: Monad m => MarloweServer m a -> Peer Marlowe 'AsServer 'StInit m a -marloweServerPeer MarloweServer{..} = Await (ClientAgency TokInit) \case +marloweRuntimeServerPeer :: Monad m => MarloweRuntimeServer m a -> Peer MarloweRuntime 'AsServer 'StInit m a +marloweRuntimeServerPeer MarloweRuntimeServer{..} = Await (ClientAgency TokInit) \case MsgRunMarloweSync -> result <$ withHandshake (marloweSyncPeer (ClientAgency Sync.TokInit)) getMarloweSyncDriver MsgRunMarloweHeaderSync -> result <$ withHandshake (marloweHeaderSyncPeer (ClientAgency Header.TokIdle)) getMarloweHeaderSyncDriver MsgRunMarloweQuery -> result <$ withHandshake (marloweQueryPeer (ClientAgency Query.TokReq)) getMarloweQueryDriver @@ -48,9 +48,9 @@ marloweServerPeer MarloweServer{..} = Await (ClientAgency TokInit) \case withHandshake :: forall ps dState st m a . (Monad m, Handshake.HasSignature ps) - => (dState -> Driver ps dState m -> Peer Marlowe 'AsServer st m a) + => (dState -> Driver ps dState m -> Peer MarloweRuntime 'AsServer st m a) -> m (Driver (Handshake ps) dState m) - -> Peer Marlowe 'AsServer st m a + -> Peer MarloweRuntime 'AsServer st m a withHandshake main getDriver = Effect do driver <- getDriver sendMessage driver (ClientAgency Handshake.TokInit) $ Handshake.MsgHandshake $ signature $ Proxy @ps @@ -79,7 +79,7 @@ marloweSyncPeer => PeerHasAgency pr st -> dState -> Driver MarloweSync dState m - -> Peer Marlowe 'AsServer ('StMarloweSync st) m () + -> Peer MarloweRuntime 'AsServer ('StMarloweSync st) m () marloweSyncPeer tok dState driver = case tok of ClientAgency tok' -> Await (ClientAgency $ TokClientMarloweSync tok') \case MsgMarloweSync msg -> Effect do @@ -108,7 +108,7 @@ marloweHeaderSyncPeer => PeerHasAgency pr st -> dState -> Driver MarloweHeaderSync dState m - -> Peer Marlowe 'AsServer ('StMarloweHeaderSync st) m () + -> Peer MarloweRuntime 'AsServer ('StMarloweHeaderSync st) m () marloweHeaderSyncPeer tok dState driver = case tok of ClientAgency tok' -> Await (ClientAgency $ TokClientMarloweHeaderSync tok') \case MsgMarloweHeaderSync msg -> Effect do @@ -133,7 +133,7 @@ marloweQueryPeer => PeerHasAgency pr st -> dState -> Driver MarloweQuery dState m - -> Peer Marlowe 'AsServer ('StMarloweQuery st) m () + -> Peer MarloweRuntime 'AsServer ('StMarloweQuery st) m () marloweQueryPeer tok dState driver = case tok of ClientAgency tok' -> Await (ClientAgency $ TokClientMarloweQuery tok') \case MsgMarloweQuery msg -> Effect do @@ -151,7 +151,7 @@ jobPeer => PeerHasAgency pr st -> dState -> Driver (Job MarloweTxCommand) dState m - -> Peer Marlowe 'AsServer ('StTxJob st) m () + -> Peer MarloweRuntime 'AsServer ('StTxJob st) m () jobPeer tok dState driver = case tok of ClientAgency tok' -> Await (ClientAgency $ TokClientTxJob tok') \case MsgTxJob msg -> Effect do diff --git a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Types.hs b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Types.hs index ece25cce27..e9cb507344 100644 --- a/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Types.hs +++ b/marlowe-runtime/proxy-api/Language/Marlowe/Protocol/Types.hs @@ -24,23 +24,23 @@ import qualified Network.Protocol.Job.Types as Job import Network.TypedProtocol import Observe.Event.Network.Protocol (MessageToJSON(..)) -data Marlowe where - StInit :: Marlowe - StMarloweSync :: MarloweSync -> Marlowe - StMarloweHeaderSync :: MarloweHeaderSync -> Marlowe - StMarloweQuery :: MarloweQuery -> Marlowe - StTxJob :: Job MarloweTxCommand -> Marlowe +data MarloweRuntime where + StInit :: MarloweRuntime + StMarloweSync :: MarloweSync -> MarloweRuntime + StMarloweHeaderSync :: MarloweHeaderSync -> MarloweRuntime + StMarloweQuery :: MarloweQuery -> MarloweRuntime + StTxJob :: Job MarloweTxCommand -> MarloweRuntime -instance Protocol Marlowe where - data Message Marlowe st st' where - MsgRunMarloweSync :: Message Marlowe 'StInit ('StMarloweSync 'MarloweSync.StInit) - MsgRunMarloweHeaderSync :: Message Marlowe 'StInit ('StMarloweHeaderSync 'MarloweHeaderSync.StIdle) - MsgRunMarloweQuery :: Message Marlowe 'StInit ('StMarloweQuery 'MarloweQuery.StReq) - MsgRunTxJob :: Message Marlowe 'StInit ('StTxJob 'Job.StInit) - MsgMarloweSync :: Message MarloweSync st st' -> Message Marlowe ('StMarloweSync st) ('StMarloweSync st') - MsgMarloweHeaderSync :: Message MarloweHeaderSync st st' -> Message Marlowe ('StMarloweHeaderSync st) ('StMarloweHeaderSync st') - MsgMarloweQuery :: Message MarloweQuery st st' -> Message Marlowe ('StMarloweQuery st) ('StMarloweQuery st') - MsgTxJob :: Message (Job MarloweTxCommand) st st' -> Message Marlowe ('StTxJob st) ('StTxJob st') +instance Protocol MarloweRuntime where + data Message MarloweRuntime st st' where + MsgRunMarloweSync :: Message MarloweRuntime 'StInit ('StMarloweSync 'MarloweSync.StInit) + MsgRunMarloweHeaderSync :: Message MarloweRuntime 'StInit ('StMarloweHeaderSync 'MarloweHeaderSync.StIdle) + MsgRunMarloweQuery :: Message MarloweRuntime 'StInit ('StMarloweQuery 'MarloweQuery.StReq) + MsgRunTxJob :: Message MarloweRuntime 'StInit ('StTxJob 'Job.StInit) + MsgMarloweSync :: Message MarloweSync st st' -> Message MarloweRuntime ('StMarloweSync st) ('StMarloweSync st') + MsgMarloweHeaderSync :: Message MarloweHeaderSync st st' -> Message MarloweRuntime ('StMarloweHeaderSync st) ('StMarloweHeaderSync st') + MsgMarloweQuery :: Message MarloweQuery st st' -> Message MarloweRuntime ('StMarloweQuery st) ('StMarloweQuery st') + MsgTxJob :: Message (Job MarloweTxCommand) st st' -> Message MarloweRuntime ('StTxJob st) ('StTxJob st') data ClientHasAgency st where TokInit :: ClientHasAgency 'StInit @@ -92,7 +92,7 @@ instance Protocol Marlowe where TokNobodyTxJob tok -> \case TokServerTxJob tok' -> exclusionLemma_NobodyAndServerHaveAgency tok tok' -instance BinaryMessage Marlowe where +instance BinaryMessage MarloweRuntime where putMessage = \case ClientAgency TokInit -> \case MsgRunMarloweSync -> putWord8 0x00 @@ -148,7 +148,7 @@ instance BinaryMessage Marlowe where SomeMessage msg <- getMessage (ServerAgency tok) pure $ SomeMessage $ MsgTxJob msg -instance MessageToJSON Marlowe where +instance MessageToJSON MarloweRuntime where messageToJSON = \case ClientAgency TokInit -> \case MsgRunMarloweSync -> String "run-marlowe-sync" @@ -188,9 +188,9 @@ instance MessageToJSON Marlowe where [ "tx-job" .= messageToJSON (ServerAgency tok) msg ] -instance HasSignature Marlowe where +instance HasSignature MarloweRuntime where signature _ = fold $ intersperse " " - [ "Marlowe" + [ "MarloweRuntime" , signature $ Proxy @MarloweSync , signature $ Proxy @MarloweHeaderSync , signature $ Proxy @MarloweQuery diff --git a/marlowe-runtime/proxy/Language/Marlowe/Runtime/Proxy.hs b/marlowe-runtime/proxy/Language/Marlowe/Runtime/Proxy.hs index e77b02777a..9da2db5dce 100644 --- a/marlowe-runtime/proxy/Language/Marlowe/Runtime/Proxy.hs +++ b/marlowe-runtime/proxy/Language/Marlowe/Runtime/Proxy.hs @@ -18,7 +18,7 @@ import Control.Monad.With (MonadWith(..)) import Data.GeneralAllocate (GeneralAllocate(..), GeneralAllocated(..), GeneralReleaseType(..)) import Language.Marlowe.Protocol.HeaderSync.Types (MarloweHeaderSync) import Language.Marlowe.Protocol.Query.Types (MarloweQuery) -import Language.Marlowe.Protocol.Server (MarloweServer(..)) +import Language.Marlowe.Protocol.Server (MarloweRuntimeServer(..)) import Language.Marlowe.Protocol.Sync.Types (MarloweSync) import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand) import Network.Protocol.Connection (SomeConnectionSource, SomeServerConnector, acceptSomeConnector) @@ -55,7 +55,7 @@ data ProxyDependencies = forall dState. ProxyDependencies , getMarloweHeaderSyncDriver :: ServerM (Driver (Handshake MarloweHeaderSync) dState ServerM) , getMarloweQueryDriver :: ServerM (Driver (Handshake MarloweQuery) dState ServerM) , getTxJobDriver :: ServerM (Driver (Handshake (Job MarloweTxCommand)) dState ServerM) - , connectionSource :: SomeConnectionSource MarloweServer ServerM + , connectionSource :: SomeConnectionSource MarloweRuntimeServer ServerM , httpPort :: Int } @@ -78,8 +78,8 @@ data WorkerDependencies = forall dState. WorkerDependencies , getMarloweHeaderSyncDriver :: ServerM (Driver (Handshake MarloweHeaderSync) dState ServerM) , getMarloweQueryDriver :: ServerM (Driver (Handshake MarloweQuery) dState ServerM) , getTxJobDriver :: ServerM (Driver (Handshake (Job MarloweTxCommand)) dState ServerM) - , connector :: SomeServerConnector MarloweServer ServerM + , connector :: SomeServerConnector MarloweRuntimeServer ServerM } worker :: WorkerDependencies -> IO () -worker WorkerDependencies{..} = runResourceT $ runWrappedUnliftIO $ runSomeConnector connector MarloweServer{result = (), ..} +worker WorkerDependencies{..} = runResourceT $ runWrappedUnliftIO $ runSomeConnector connector MarloweRuntimeServer{result = (), ..}