Merge pull request #442 from input-output-hk/scp-4875-header-sync
SCP-4875 MarloweHeaderSync Server
SCP-4875 MarloweHeaderSync Server
Runtime.
Usage: marlowe-sync (-d|--database-uri DATABASE_URI) [--sync-port PORT_NUMBER]
[-h|--host HOST_NAME] [--log-config-file FILE_PATH]
[--header-sync-port PORT_NUMBER] [-h|--host HOST_NAME]
[--log-config-file FILE_PATH]
Contract synchronization and query service for Marlowe Runtime
-d,--database-uri DATABASE_URI
URI of the database where the contract information is
saved.
--sync-port PORT_NUMBER The port number to run the sync server on.
--sync-port PORT_NUMBER The port number to run the sync protocol on.
(default: 3724)
--header-sync-port PORT_NUMBER
The port number to run the header sync protocol on.
(default: 3725)
-h,--host HOST_NAME The host name to run the server on.
(default: "127.0.0.1")
--log-config-file FILE_PATH
visibility: public
exposed-modules:
Language.Marlowe.Runtime.Sync
Language.Marlowe.Runtime.Sync.MarloweHeaderSyncServer
Language.Marlowe.Runtime.Sync.MarloweSyncServer
Language.Marlowe.Runtime.Sync.Database
Language.Marlowe.Runtime.Sync.Database.PostgreSQL
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTip
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTipForContract
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetCreateStep
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetIntersectionForContract
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetIntersection
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextHeaders
Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextSteps
build-depends:
base >= 4.9 && < 5
, marlowe-chain-sync
, marlowe-protocols
, marlowe-runtime
, marlowe-runtime:discovery-api
, marlowe-runtime:history-api
, plutus-ledger-api
, text
, hasql
, hasql-pool
, marlowe-protocols
, marlowe-runtime:discovery-api
, marlowe-runtime:history-api
, marlowe-runtime:sync
, network
, getRootSelectorConfig
) where
import Language.Marlowe.Protocol.HeaderSync.Types (MarloweHeaderSync)
import Language.Marlowe.Protocol.Sync.Types (MarloweSync)
import Language.Marlowe.Runtime.Sync.Database (DatabaseSelector, getDatabaseSelectorConfig)
import Network.Protocol.Driver
data RootSelector f where
MarloweSyncServer :: AcceptSocketDriverSelector MarloweSync f -> RootSelector f
MarloweHeaderSyncServer :: AcceptSocketDriverSelector MarloweHeaderSync f -> RootSelector f
Database :: DatabaseSelector f -> RootSelector f
ConfigWatcher :: ConfigWatcherSelector f -> RootSelector f
getRootSelectorConfig :: GetSelectorConfig RootSelector
getRootSelectorConfig = \case
MarloweSyncServer sel -> prependKey "marlowe-sync-server" $ getAcceptSocketDriverSelectorConfig marloweSyncServerConfig sel
MarloweHeaderSyncServer sel -> prependKey "marlowe-header-sync-server" $ getAcceptSocketDriverSelectorConfig marloweHeaderSyncServerConfig sel
Database sel -> prependKey "database" $ getDatabaseSelectorConfig sel
ConfigWatcher ReloadConfig -> SelectorConfig "reload-log-config" True
$ singletonFieldConfig "config" True
, enableDisconnected = True
, enableServerDriverEvent = True
}
marloweHeaderSyncServerConfig :: SocketDriverConfigOptions
marloweHeaderSyncServerConfig = SocketDriverConfigOptions
{ enableConnected = True
, enableDisconnected = True
, enableServerDriverEvent = True
}
import Data.UUID.V4 (nextRandom)
import qualified Hasql.Pool as Pool
import qualified Hasql.Session as Session
import Language.Marlowe.Protocol.HeaderSync.Codec (codecMarloweHeaderSync)
import Language.Marlowe.Protocol.HeaderSync.Server (marloweHeaderSyncServerPeer)
import Language.Marlowe.Protocol.Sync.Codec (codecMarloweSync)
import Language.Marlowe.Protocol.Sync.Server (marloweSyncServerPeer)
import Language.Marlowe.Runtime.Sync (SyncDependencies(..), sync)
run Options{..} = withSocketsDo do
pool <- Pool.acquire (100, secondsToNominalDiffTime 5, fromString databaseUri)
marloweSyncAddr <- resolve marloweSyncPort
marloweHeaderSyncAddr <- resolve marloweHeaderSyncPort
bracket (openServer marloweSyncAddr) close \syncSocket -> do
let
appDependencies eventBackend =
let
databaseQueries = logDatabaseQueries (narrowEventBackend Database eventBackend) $ hoistDatabaseQueries
(either throwUsageError pure <=< Pool.use pool)
Postgres.databaseQueries
acceptRunMarloweSyncServer = acceptRunServerPeerOverSocketWithLogging
(narrowEventBackend MarloweSyncServer eventBackend)
throwIO
syncSocket
codecMarloweSync
marloweSyncServerPeer
in SyncDependencies{..}
let appComponent = sync <<< arr appDependencies <<< logger
runComponent_ appComponent LoggerDependencies
{ configFilePath = logConfigFile
, getSelectorConfig = getRootSelectorConfig
, newRef = nextRandom
, newOnceFlag = newOnceFlagMVar
, writeText = TL.hPutStr stderr
, injectConfigWatcherSelector = ConfigWatcher
}
bracket (openServer marloweHeaderSyncAddr) close \headerSyncSocket -> do
let
appDependencies eventBackend =
let
databaseQueries = logDatabaseQueries (narrowEventBackend Database eventBackend) $ hoistDatabaseQueries
(either throwUsageError pure <=< Pool.use pool)
Postgres.databaseQueries
acceptRunMarloweSyncServer = acceptRunServerPeerOverSocketWithLogging
(narrowEventBackend MarloweSyncServer eventBackend)
throwIO
syncSocket
codecMarloweSync
marloweSyncServerPeer
acceptRunMarloweHeaderSyncServer = acceptRunServerPeerOverSocketWithLogging
(narrowEventBackend MarloweHeaderSyncServer eventBackend)
throwIO
headerSyncSocket
codecMarloweHeaderSync
marloweHeaderSyncServerPeer
in SyncDependencies{..}
let appComponent = sync <<< arr appDependencies <<< logger
runComponent_ appComponent LoggerDependencies
{ configFilePath = logConfigFile
, getSelectorConfig = getRootSelectorConfig
, newRef = nextRandom
, newOnceFlag = newOnceFlagMVar
, writeText = TL.hPutStr stderr
, injectConfigWatcherSelector = ConfigWatcher
}
where
throwUsageError (Pool.ConnectionError err) = error $ show err
throwUsageError (Pool.SessionError (Session.QueryError _ _ err)) = error $ show err
data Options = Options
{ databaseUri :: String
, marloweSyncPort :: PortNumber
, marloweHeaderSyncPort :: PortNumber
, host :: HostName
, logConfigFile :: Maybe FilePath
}
parser = Options
<$> databaseUriParser
<*> marloweSyncPortParser
<*> marloweHeaderSyncPortParser
<*> hostParser
<*> logConfigFileParser
[ long "sync-port"
, value 3724
, metavar "PORT_NUMBER"
, help "The port number to run the sync server on."
, help "The port number to run the sync protocol on."
, showDefault
]
marloweHeaderSyncPortParser = option auto $ mconcat
[ long "header-sync-port"
, value 3725
, metavar "PORT_NUMBER"
, help "The port number to run the header sync protocol on."
, showDefault
]
where
import Control.Concurrent.Component
import Language.Marlowe.Protocol.HeaderSync.Server (MarloweHeaderSyncServer)
import Language.Marlowe.Protocol.Sync.Server (MarloweSyncServer)
import Language.Marlowe.Runtime.Sync.Database (DatabaseQueries)
import Language.Marlowe.Runtime.Sync.MarloweHeaderSyncServer
import Language.Marlowe.Runtime.Sync.MarloweSyncServer (MarloweSyncServerDependencies(..), marloweSyncServer)
import Network.Protocol.Driver (RunServer)
data SyncDependencies = SyncDependencies
{ databaseQueries :: DatabaseQueries IO
, acceptRunMarloweSyncServer :: IO (RunServer IO MarloweSyncServer)
, acceptRunMarloweHeaderSyncServer :: IO (RunServer IO MarloweHeaderSyncServer)
}
sync :: Component IO SyncDependencies ()
sync = proc SyncDependencies{..} -> do
marloweSyncServer -< MarloweSyncServerDependencies{..}
marloweHeaderSyncServer -< MarloweHeaderSyncServerDependencies{..}
import Control.Monad.Cleanup (MonadCleanup)
import Data.Aeson (ToJSON)
import Data.Text (Text)
import Data.Void (Void)
import GHC.Generics (Generic)
import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint)
import Language.Marlowe.Runtime.Core.Api (ContractId, MarloweVersion(..), MarloweVersionTag(..), SomeMarloweVersion)
import Language.Marlowe.Runtime.Core.Api (ContractId, MarloweVersion(..), SomeMarloweVersion)
import Language.Marlowe.Runtime.Discovery.Api (ContractHeader)
import Language.Marlowe.Runtime.History.Api (ContractStep, SomeCreateStep)
import Observe.Event (EventBackend, addField, withEvent)
import Observe.Event.Component (FieldConfig(..), GetSelectorConfig, SelectorConfig(SelectorConfig), SomeJSON(SomeJSON))
data DatabaseSelector f where
GetTip :: DatabaseSelector (QueryField Void ChainPoint)
GetTipForContract :: DatabaseSelector (QueryField ContractId ChainPoint)
GetCreateStep :: DatabaseSelector (QueryField ContractId (Maybe GetCreateStepResult))
GetIntersectionForContract :: DatabaseSelector (QueryField GetIntersectionForContractArguments (Maybe GetIntersectionForContractResult))
GetNextSteps :: MarloweVersion v -> DatabaseSelector (QueryField (GetNextStepsArguments v) (NextSteps v))
GetIntersection :: DatabaseSelector (QueryField [BlockHeader] (Maybe BlockHeader))
GetNextHeaders :: DatabaseSelector (QueryField ChainPoint (Next ContractHeader))
GetNextSteps :: MarloweVersion v -> DatabaseSelector (QueryField (GetNextStepsArguments v) (Next (ContractStep v)))
data QueryField p r
= Arguments p
logDatabaseQueries :: MonadCleanup m => EventBackend m r DatabaseSelector -> DatabaseQueries m -> DatabaseQueries m
logDatabaseQueries eventBackend DatabaseQueries{..} = DatabaseQueries
{ getTipForContract = \contractId -> withEvent eventBackend GetTipForContract \ev -> do
{ getTip = withEvent eventBackend GetTip \ev -> do
result <- getTip
addField ev $ Result result
pure result
, getTipForContract = \contractId -> withEvent eventBackend GetTipForContract \ev -> do
addField ev $ Arguments contractId
result <- getTipForContract contractId
addField ev $ Result result
result <- getCreateStep contractId
addField ev $ Result $ uncurry GetCreateStepResult <$> result
pure result
, getIntersection = \points -> withEvent eventBackend GetIntersection \ev -> do
addField ev $ Arguments points
result <- getIntersection points
addField ev $ Result result
pure result
, getIntersectionForContract = \contractId points -> withEvent eventBackend GetIntersectionForContract \ev -> do
addField ev $ Arguments $ GetIntersectionForContractArguments{..}
result <- getIntersectionForContract contractId points
addField ev $ Result $ uncurry GetIntersectionForContractResult <$> result
pure result
, getNextHeaders = \fromPoint -> withEvent eventBackend GetNextHeaders \ev -> do
addField ev $ Arguments fromPoint
result <- getNextHeaders fromPoint
addField ev $ Result result
pure result
, getNextSteps = \version contractId fromPoint -> withEvent eventBackend (GetNextSteps version) \ev -> do
addField ev $ Arguments $ GetNextStepsArguments{..}
result <- getNextSteps version contractId fromPoint
hoistDatabaseQueries :: (forall x. m x -> n x) -> DatabaseQueries m -> DatabaseQueries n
hoistDatabaseQueries f DatabaseQueries{..} = DatabaseQueries
{ getTipForContract = f . getTipForContract
{ getTip = f getTip
, getTipForContract = f . getTipForContract
, getCreateStep = f . getCreateStep
, getIntersectionForContract = fmap f . getIntersectionForContract
, getIntersection = f . getIntersection
, getNextHeaders = f . getNextHeaders
, getNextSteps = (fmap . fmap) f . getNextSteps
}
data DatabaseQueries m = DatabaseQueries
{ getTipForContract :: ContractId -> m ChainPoint
{ getTip :: m ChainPoint
, getTipForContract :: ContractId -> m ChainPoint
, getCreateStep :: ContractId -> m (Maybe (BlockHeader, SomeCreateStep))
, getIntersection :: [BlockHeader] -> m (Maybe BlockHeader)
, getIntersectionForContract :: ContractId -> [BlockHeader] -> m (Maybe (BlockHeader, SomeMarloweVersion))
, getNextSteps :: forall v. MarloweVersion v -> ContractId -> ChainPoint -> m (NextSteps v)
, getNextHeaders :: ChainPoint -> m (Next ContractHeader)
, getNextSteps :: forall v. MarloweVersion v -> ContractId -> ChainPoint -> m (Next (ContractStep v))
}
data NextSteps v
data Next a
= Rollback ChainPoint
| Wait
| Next BlockHeader [ContractStep v]
deriving stock (Generic)
instance ToJSON (NextSteps 'V1)
| Next BlockHeader [a]
deriving stock (Generic, Functor)
deriving anyclass (ToJSON)
getDatabaseSelectorConfig :: GetSelectorConfig DatabaseSelector
getDatabaseSelectorConfig = \case
GetTip -> getQuerySelectorConfig "get-tip"
GetTipForContract -> getQuerySelectorConfig "get-tip-for-contract"
GetCreateStep -> getQuerySelectorConfig "get-create-step"
GetIntersectionForContract -> getQuerySelectorConfig "get-intersection-for-contract"
GetIntersection -> getQuerySelectorConfig "get-intersection"
GetNextHeaders -> getQuerySelectorConfig "get-next-headers"
GetNextSteps MarloweV1 -> getQuerySelectorConfig "get-next-steps"
getQuerySelectorConfig :: (ToJSON p, ToJSON r) => Text -> SelectorConfig (QueryField p r)
import qualified Hasql.Transaction.Sessions as T
import Language.Marlowe.Runtime.Sync.Database (DatabaseQueries(DatabaseQueries))
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetCreateStep (getCreateStep)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetIntersection (getIntersection)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetIntersectionForContract (getIntersectionForContract)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextHeaders (getNextHeaders)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextSteps (getNextSteps)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTip (getTip)
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTipForContract (getTipForContract)
databaseQueries :: DatabaseQueries H.Session
databaseQueries = DatabaseQueries
(T.transaction T.Serializable T.Read getTip)
(T.transaction T.Serializable T.Read . getTipForContract)
(T.transaction T.Serializable T.Read . getCreateStep)
(T.transaction T.Serializable T.Read . getIntersection)
(\contractId -> T.transaction T.Serializable T.Read . getIntersectionForContract contractId)
(T.transaction T.Serializable T.Read . getNextHeaders)
(\version contractId -> T.transaction T.Serializable T.Read . getNextSteps version contractId)
{-# LANGUAGE QuasiQuotes #-}
module Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetIntersection
where
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Maybe (listToMaybe)
import qualified Data.Vector as V
import Hasql.TH (vectorStatement)
import qualified Hasql.Transaction as T
import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader(..), BlockHeaderHash(..))
getIntersection :: [BlockHeader] -> T.Transaction (Maybe BlockHeader)
getIntersection [] = pure Nothing
getIntersection (b : bs) = do
serverBlocks <- fmap decodeBlock . V.toList <$> T.statement (fromIntegral $ slotNo b)
[vectorStatement|
SELECT
block.slotNo :: bigint,
block.id :: bytea,
block.blockNo :: bigint
FROM marlowe.block
WHERE slotNo >= $1 :: bigint
ORDER BY slotNo
|]
pure
$ fmap fst
$ listToMaybe
$ reverse
$ takeWhile (uncurry (==))
$ zip (b : bs)
$ dropWhile (/= b) serverBlocks
decodeBlock :: (Int64, ByteString, Int64) -> BlockHeader
decodeBlock (slot, hash, block) = BlockHeader
(fromIntegral slot)
(BlockHeaderHash hash)
(fromIntegral block)
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
module Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextHeaders
where
import Data.Binary (get)
import Data.Binary.Get (runGet)
import Data.ByteString.Lazy (fromStrict)
import Data.Maybe (fromJust)
import qualified Data.Vector as V
import Hasql.TH (vectorStatement)
import qualified Hasql.Transaction as T
import Language.Marlowe.Runtime.ChainSync.Api
( Address(..)
, BlockHeader(..)
, BlockHeaderHash(..)
, ChainPoint
, Credential(..)
, PolicyId(..)
, ScriptHash(..)
, TxId(..)
, TxOutRef(..)
, WithGenesis(..)
, paymentCredential
)
import Language.Marlowe.Runtime.Core.Api
(ContractId(..), MarloweVersion(MarloweV1), SomeMarloweVersion(SomeMarloweVersion))
import Language.Marlowe.Runtime.Discovery.Api (ContractHeader(..))
import Language.Marlowe.Runtime.Sync.Database (Next(..))
import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextSteps (Orientation(..), orient)
import Prelude hiding (init)
getNextHeaders :: ChainPoint -> T.Transaction (Next ContractHeader)
getNextHeaders point = do
orient point >>= \case
RolledBack toPoint -> pure $ Rollback toPoint
AtTip -> pure Wait
BeforeTip -> T.statement fromSlot $ decodeResult . V.toList <$>
[vectorStatement|
WITH nextBlock AS
( SELECT
block.slotNo,
block.id as blockId,
block.blockNo
FROM marlowe.block
JOIN marlowe.createTxOut
ON createTxOut.blockId = block.id
WHERE block.rollbackToBlock IS NULL
AND block.slotNo > $1 :: bigint
ORDER BY block.slotNo
LIMIT 1
)
SELECT
nextBlock.slotNo :: bigint,
nextBlock.blockId :: bytea,
nextBlock.blockNo :: bigint,
createTxOut.txId :: bytea,
createTxOut.txIx :: smallint,
contractTxOut.rolesCurrency :: bytea,
createTxOut.metadata :: bytea?,
txOut.address :: bytea,
contractTxOut.payoutScriptHash :: bytea
FROM nextBlock
JOIN marlowe.createTxOut USING (blockId)
JOIN marlowe.contractTxOut USING (txId, txIx)
JOIN marlowe.txOut USING (txId, txIx)
|]
where
fromSlot = case point of
Genesis -> -1
At BlockHeader{..} -> fromIntegral slotNo
decodeResult [] = Wait
decodeResult (row : rows) =
let
blockHeader = decodeBlockHeader row
in
Next blockHeader $ decodeContractHeader blockHeader <$> row : rows
decodeBlockHeader
( slot
, hash
, block
, _
, _
, _
, _
, _
, _
) = BlockHeader
(fromIntegral slot)
(BlockHeaderHash hash)
(fromIntegral block)
decodeContractHeader blockHeader
( _
, _
, _
, txId
, txIx
, rolesCurrency
, metadata
, marloweScriptAddress
, payoutScriptHash
) = ContractHeader
{ contractId = ContractId $ TxOutRef (TxId txId) (fromIntegral txIx)
, rolesCurrency = PolicyId rolesCurrency
, metadata = maybe mempty (runGet get. fromStrict) metadata
, marloweScriptHash = fromJust do
credential <- paymentCredential $ Address marloweScriptAddress
case credential of
ScriptCredential hash -> pure hash
_ -> Nothing
, marloweScriptAddress = Address marloweScriptAddress
, payoutScriptHash = ScriptHash payoutScriptHash
, marloweVersion = SomeMarloweVersion MarloweV1
, blockHeader
}
, TransactionScriptOutput(..)
)
import Language.Marlowe.Runtime.History.Api (ContractStep(..), RedeemStep(..))
import Language.Marlowe.Runtime.Sync.Database (NextSteps(..))
import Language.Marlowe.Runtime.Sync.Database (Next(..))
import qualified Plutus.V2.Ledger.Api as PV2
import Prelude hiding (init)
import Witherable (catMaybes, mapMaybe)
getNextSteps :: MarloweVersion v -> ContractId -> ChainPoint -> T.Transaction (NextSteps v)
getNextSteps :: MarloweVersion v -> ContractId -> ChainPoint -> T.Transaction (Next (ContractStep v))
getNextSteps MarloweV1 contractId point = do
orient point >>= \case
RolledBack toPoint -> pure $ Rollback toPoint
{-# LANGUAGE QuasiQuotes #-}
module Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTip
where
import Hasql.TH (maybeStatement)
import qualified Hasql.Transaction as T
import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader(..), BlockHeaderHash(..), ChainPoint, WithGenesis(..))
getTip :: T.Transaction ChainPoint
getTip = T.statement () $ decodePoint <$>
[maybeStatement|
SELECT
block.slotNo :: bigint,
block.id :: bytea,
block.blockNo :: bigint
FROM marlowe.block
ORDER BY block.slotNo DESC
LIMIT 1
|]
where
decodePoint = \case
Nothing -> Genesis
Just (slot, hash, block) -> At $ BlockHeader
(fromIntegral slot)
(BlockHeaderHash hash)
(fromIntegral block)
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE GADTs #-}
module Language.Marlowe.Runtime.Sync.MarloweHeaderSyncServer
where
import Control.Concurrent.Component
import Language.Marlowe.Protocol.HeaderSync.Server
import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, WithGenesis(..))
import Language.Marlowe.Runtime.Sync.Database (DatabaseQueries(..), Next(..))
import Network.Protocol.Driver (RunServer(..))
data MarloweHeaderSyncServerDependencies = MarloweHeaderSyncServerDependencies
{ databaseQueries :: DatabaseQueries IO
, acceptRunMarloweHeaderSyncServer :: IO (RunServer IO MarloweHeaderSyncServer)
}
marloweHeaderSyncServer :: Component IO MarloweHeaderSyncServerDependencies ()
marloweHeaderSyncServer = serverComponent (component_ worker) \MarloweHeaderSyncServerDependencies{..} -> do
runMarloweHeaderSyncServer <- acceptRunMarloweHeaderSyncServer
pure WorkerDependencies{..}
data WorkerDependencies = WorkerDependencies
{ databaseQueries :: DatabaseQueries IO
, runMarloweHeaderSyncServer :: RunServer IO MarloweHeaderSyncServer
}
worker :: WorkerDependencies -> IO ()
worker WorkerDependencies{..} = do
let RunServer runServer = runMarloweHeaderSyncServer
runServer $ MarloweHeaderSyncServer $ pure $ serverIdle Genesis
where
DatabaseQueries{..} = databaseQueries
serverIdle :: ChainPoint -> ServerStIdle IO ()
serverIdle clientPos = ServerStIdle
{ recvMsgRequestNext
, recvMsgIntersect
, recvMsgDone = pure ()
}
where
recvMsgRequestNext = do
nextHeaders <- getNextHeaders clientPos
pure case nextHeaders of
Rollback targetPoint -> SendMsgRollBackward targetPoint $ serverIdle targetPoint
Wait -> SendMsgWait ServerStWait
{ recvMsgPoll = recvMsgRequestNext
, recvMsgCancel = pure $ serverIdle clientPos
}
Next nextBlock headers -> SendMsgNewHeaders nextBlock headers $ serverIdle $ At nextBlock
recvMsgIntersect :: [BlockHeader] -> IO (ServerStIntersect IO ())
recvMsgIntersect points = do
mIntersection <- getIntersection points
pure case mIntersection of
Nothing -> SendMsgIntersectNotFound $ serverIdle clientPos
Just intersection -> SendMsgIntersectFound intersection $ serverIdle $ At intersection
import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, WithGenesis(..))
import Language.Marlowe.Runtime.Core.Api (ContractId, MarloweVersion, SomeMarloweVersion(..))
import Language.Marlowe.Runtime.History.Api (SomeCreateStep(..))
import Language.Marlowe.Runtime.Sync.Database (DatabaseQueries(..), NextSteps(..))
import Language.Marlowe.Runtime.Sync.Database (DatabaseQueries(..), Next(..))
import Network.Protocol.Driver (RunServer(..))
data MarloweSyncServerDependencies = MarloweSyncServerDependencies
};
sync-service = dev-service {
ports = [ 3724 ];
ports = [ 3724 3725 ];
depends_on = [ "marlowe-indexer" "postgres" ];
command = [
"/exec/run-marlowe-sync"
web-service = dev-service {
ports = [ 8080 ];
depends_on = [ "marlowe-sync" "marlowe-discovery" "marlowe-tx" ];
depends_on = [ "marlowe-sync" "marlowe-tx" ];
command = [
"/exec/run-marlowe-web-server"
"--history-host"
"marlowe-sync"
"--history-sync-port"
"3724"
"--discovery-sync-port"
"3725"
"--discovery-host"
"marlowe-discovery"
"marlowe-sync"
"--tx-host"
"marlowe-tx"
"--enable-open-api"
(hsPkgs."marlowe-chain-sync" or (errorHandler.buildDepError "marlowe-chain-sync"))
(hsPkgs."marlowe-protocols" or (errorHandler.buildDepError "marlowe-protocols"))
(hsPkgs."marlowe-runtime" or (errorHandler.buildDepError "marlowe-runtime"))
(hsPkgs."marlowe-runtime".components.sublibs.discovery-api or (errorHandler.buildDepError "marlowe-runtime:discovery-api"))
(hsPkgs."marlowe-runtime".components.sublibs.history-api or (errorHandler.buildDepError "marlowe-runtime:history-api"))
(hsPkgs."plutus-ledger-api" or (errorHandler.buildDepError "plutus-ledger-api"))
(hsPkgs."text" or (errorHandler.buildDepError "text"))
buildable = true;
modules = [
"Language/Marlowe/Runtime/Sync"
"Language/Marlowe/Runtime/Sync/MarloweHeaderSyncServer"
"Language/Marlowe/Runtime/Sync/MarloweSyncServer"
"Language/Marlowe/Runtime/Sync/Database"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetTip"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetTipForContract"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetCreateStep"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetIntersectionForContract"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetIntersection"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetNextHeaders"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetNextSteps"
];
hsSourceDirs = [ "sync" ];
(hsPkgs."hasql" or (errorHandler.buildDepError "hasql"))
(hsPkgs."hasql-pool" or (errorHandler.buildDepError "hasql-pool"))
(hsPkgs."marlowe-protocols" or (errorHandler.buildDepError "marlowe-protocols"))
(hsPkgs."marlowe-runtime".components.sublibs.discovery-api or (errorHandler.buildDepError "marlowe-runtime:discovery-api"))
(hsPkgs."marlowe-runtime".components.sublibs.history-api or (errorHandler.buildDepError "marlowe-runtime:history-api"))
(hsPkgs."marlowe-runtime".components.sublibs.sync or (errorHandler.buildDepError "marlowe-runtime:sync"))
(hsPkgs."network" or (errorHandler.buildDepError "network"))
(hsPkgs."marlowe-chain-sync" or (errorHandler.buildDepError "marlowe-chain-sync"))
(hsPkgs."marlowe-protocols" or (errorHandler.buildDepError "marlowe-protocols"))
(hsPkgs."marlowe-runtime" or (errorHandler.buildDepError "marlowe-runtime"))
(hsPkgs."marlowe-runtime".components.sublibs.discovery-api or (errorHandler.buildDepError "marlowe-runtime:discovery-api"))
(hsPkgs."marlowe-runtime".components.sublibs.history-api or (errorHandler.buildDepError "marlowe-runtime:history-api"))
(hsPkgs."plutus-ledger-api" or (errorHandler.buildDepError "plutus-ledger-api"))
(hsPkgs."text" or (errorHandler.buildDepError "text"))
buildable = true;
modules = [
"Language/Marlowe/Runtime/Sync"
"Language/Marlowe/Runtime/Sync/MarloweHeaderSyncServer"
"Language/Marlowe/Runtime/Sync/MarloweSyncServer"
"Language/Marlowe/Runtime/Sync/Database"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetTip"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetTipForContract"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetCreateStep"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetIntersectionForContract"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetIntersection"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetNextHeaders"
"Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetNextSteps"
];
hsSourceDirs = [ "sync" ];
(hsPkgs."hasql" or (errorHandler.buildDepError "hasql"))
(hsPkgs."hasql-pool" or (errorHandler.buildDepError "hasql-pool"))
(hsPkgs."marlowe-protocols" or (errorHandler.buildDepError "marlowe-protocols"))
(hsPkgs."marlowe-runtime".components.sublibs.discovery-api or (errorHandler.buildDepError "marlowe-runtime:discovery-api"))
(hsPkgs."marlowe-runtime".components.sublibs.history-api or (errorHandler.buildDepError "marlowe-runtime:history-api"))
(hsPkgs."marlowe-runtime".components.sublibs.sync or (errorHandler.buildDepError "marlowe-runtime:sync"))
(hsPkgs."network" or (errorHandler.buildDepError "network"))
export MARLOWE_RT_SYNC_HOST=127.0.0.1
export MARLOWE_RT_SYNC_MARLOWE_SYNC_PORT=$(docker-compose port marlowe-sync 3724 | sed -e s/://)
export MARLOWE_RT_SYNC_MARLOWE_HEADER_SYNC_PORT=$(docker-compose port marlowe-sync 3725 | sed -e s/://)
export MARLOWE_RT_HISTORY_HOST=127.0.0.1
export MARLOWE_RT_HISTORY_SYNC_PORT=$(docker-compose port marlowe-history 3719 | sed -e s/://)
fix CI not running on bors branches
5023: fix CI not running on bors branches r=disassembler a=dermetfan Looks like this was broken in #4930 as `prAndBorsIo` was added but not used. Also removed `nix` from the task name. I do not see what purpose it has and it makes the names unnecessarily long. Also we happen to need the old names in #5018. Co-authored-by: Robin Stumm <[email protected]>
I don't trust it. Compare these two runs: 1. https://github.com/input-output-hk/cardano-haskell-packages/actions/runs/4532746158/jobs/7984714895 2. https://github.com/input-output-hk/cardano-haskell-packages/actions/runs/4516172089/jobs/7954255360 The second is on the parent commit of the first, the commit itself is a no-op, and yet the derivations they build are not the same! Doing the same locally, I get a) a different derivation, but b) the same derivation for both. I conclude that what the CI is doing is questionable, the cache seems like the most likely source of pollution. I suspect whatever is causing this was also responsible for the no-op PR spending a lot of time building tons of stuff.
* Update readme (cli flags, comment dsl, new format) * Document the comment DSL * Document CLI flags * Mention new split rust/wasm output structure * Remove unsupported section (to handle in issues instead as this tends to get very outdated) * respond to comments + add supported.cddl * minor fixes for comment placement in supported.cddl + remove unsupported optional fixed value from example
Co-authored-by: Sebastien Guillemot <[email protected]>
5018: Use ouroboros-network-0.3.0.2 and ouroboros-network-framework-0.2.0.1 r=dermetfan a=coot Co-authored-by: Marcin Szamotulski <[email protected]> Co-authored-by: Samuel Leathers <[email protected]>
Waiting for a day, at a pace of one block every 20 seconds would generate 4320 blocks which takes forever to be created and processes, even in IO sim. We don't really observe the issue now because we cheat in the way we generate the block. This commit helps preparing for a more realistic block generation.