Use handshakes throughout… - input-output-hk/marlowe-cardano@c141697c

Home / Input Output / marlowe-cardano / c141697c

View on GitHub

File Changes

m

marlowe-apps/src/Language/Marlowe/Runtime/App/Run.hs

+13/-38

-

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DerivingStrategies #-}

{-# LANGUAGE RankNTypes #-}

  ) where

-

import Control.Exception (Exception, bracket, bracketOnError, throwIO)

+

import Control.Exception (throwIO)

import Control.Monad.Trans.Control (liftBaseWith)

import Control.Monad.Trans.Reader (ReaderT(..), ask)

-

import Data.ByteString.Lazy (ByteString)

import Language.Marlowe.Protocol.HeaderSync.Client

  (MarloweHeaderSyncClient, hoistMarloweHeaderSyncClient, marloweHeaderSyncClientPeer)

import Language.Marlowe.Protocol.HeaderSync.Codec (codecMarloweHeaderSync)

import Language.Marlowe.Protocol.Sync.Client (MarloweSyncClient, hoistMarloweSyncClient, marloweSyncClientPeer)

import Language.Marlowe.Protocol.Sync.Codec (codecMarloweSync)

-

import Language.Marlowe.Runtime.App.Types (Client(..), Config(..), RunClient, Services(..))

+

import Language.Marlowe.Runtime.App.Types (Client(..), Config(..), Services(..))

import Language.Marlowe.Runtime.ChainSync.Api (RuntimeChainSeekClient, WithGenesis(Genesis))

-

import Network.Channel (socketAsChannel)

import Network.Protocol.ChainSeek.Client (chainSeekClientPeer, hoistChainSeekClient)

import Network.Protocol.ChainSeek.Codec (codecChainSeek)

-

import Network.Protocol.Driver (mkDriver)

+

import Network.Protocol.Handshake.Client (runClientPeerOverSocketWithHandshake)

import Network.Protocol.Job.Client (JobClient, hoistJobClient, jobClientPeer)

import Network.Protocol.Job.Codec (codecJob)

import Network.Protocol.Query.Client (QueryClient, hoistQueryClient, queryClientPeer)

import Network.Protocol.Query.Codec (codecQuery)

-

import Network.Socket

-

  (AddrInfo, SocketType(..), addrAddress, addrSocketType, close, connect, defaultHints, getAddrInfo, openSocket)

-

import Network.TypedProtocol (Driver(startDState), Peer, PeerRole(..), runPeerWithDriver)

-

import Network.TypedProtocol.Codec (Codec)

+

import Network.Socket (SocketType(..), addrSocketType, defaultHints, getAddrInfo)

runQueryClient

  discoverySyncAddr <- resolve discoveryHost discoverySyncPort

  txJobAddr <- resolve txHost txCommandPort

  runReaderT (runClient client) Services

-

    { runChainSeekCommandClient = runClientPeerOverSocket chainSeekCommandAddr codecJob jobClientPeer

-

    , runChainSeekQueryClient = runClientPeerOverSocket chainSeekQueryAddr codecQuery queryClientPeer

-

    , runChainSeekSyncClient = runClientPeerOverSocket chainSeekSyncAddr codecChainSeek (chainSeekClientPeer Genesis)

-

    , runHistoryCommandClient = runClientPeerOverSocket historyJobAddr codecJob jobClientPeer

-

    , runHistoryQueryClient = runClientPeerOverSocket historyQueryAddr codecQuery queryClientPeer

-

    , runHistorySyncClient = runClientPeerOverSocket historySyncAddr codecMarloweSync marloweSyncClientPeer

-

    , runTxCommandClient = runClientPeerOverSocket txJobAddr codecJob jobClientPeer

-

    , runDiscoveryQueryClient = runClientPeerOverSocket discoveryQueryAddr codecQuery queryClientPeer

-

    , runDiscoverySyncClient = runClientPeerOverSocket discoverySyncAddr codecMarloweHeaderSync marloweHeaderSyncClientPeer

+

    { runChainSeekCommandClient = runClientPeerOverSocketWithHandshake throwIO chainSeekCommandAddr codecJob jobClientPeer

+

    , runChainSeekQueryClient = runClientPeerOverSocketWithHandshake throwIO chainSeekQueryAddr codecQuery queryClientPeer

+

    , runChainSeekSyncClient = runClientPeerOverSocketWithHandshake throwIO chainSeekSyncAddr codecChainSeek (chainSeekClientPeer Genesis)

+

    , runHistoryCommandClient = runClientPeerOverSocketWithHandshake throwIO historyJobAddr codecJob jobClientPeer

+

    , runHistoryQueryClient = runClientPeerOverSocketWithHandshake throwIO historyQueryAddr codecQuery queryClientPeer

+

    , runHistorySyncClient = runClientPeerOverSocketWithHandshake throwIO historySyncAddr codecMarloweSync marloweSyncClientPeer

+

    , runTxCommandClient = runClientPeerOverSocketWithHandshake throwIO txJobAddr codecJob jobClientPeer

+

    , runDiscoveryQueryClient = runClientPeerOverSocketWithHandshake throwIO discoveryQueryAddr codecQuery queryClientPeer

+

    , runDiscoverySyncClient = runClientPeerOverSocketWithHandshake throwIO discoverySyncAddr codecMarloweHeaderSync marloweHeaderSyncClientPeer

  where

    resolve host port =

      head <$> getAddrInfo (Just defaultHints { addrSocketType = Stream }) (Just host) (Just $ show port)

-

-- | Run a client as a typed protocols peer over a socket.

-

runClientPeerOverSocket

-

  :: Exception ex

-

  => AddrInfo -- ^ Socket address to connect to

-

  -> Codec protocol ex IO ByteString -- ^ A codec for the protocol

-

  -> (forall a. client IO a -> Peer protocol 'AsClient st IO a) -- ^ Interpret the client as a protocol peer

-

  -> RunClient IO client

-

runClientPeerOverSocket addr codec clientToPeer client = bracket open close $ \socket -> do

-

  let channel = socketAsChannel socket

-

  let driver = mkDriver throwIO codec channel

-

  let peer = clientToPeer client

-

  fst <$> runPeerWithDriver driver peer (startDState driver)

-

  where

-

    open = bracketOnError (openSocket addr) close $ \sock -> do

-

      connect sock $ addrAddress addr

-

      pure sock

m

marlowe-chain-sync/chainseekd/Logging.hs

+4/-3

import Language.Marlowe.Runtime.ChainSync.Api (ChainSyncCommand, ChainSyncQuery, RuntimeChainSeek)

import Network.Protocol.Driver

  (AcceptSocketDriverSelector(..), SocketDriverConfigOptions(..), getAcceptSocketDriverSelectorConfig)

+

import Network.Protocol.Handshake.Types (Handshake)

import Network.Protocol.Job.Types (Job)

import Network.Protocol.Query.Types (Query)

import Observe.Event.Component

  (ConfigWatcherSelector(..), GetSelectorConfig, SelectorConfig(..), prependKey, singletonFieldConfig)

data RootSelector f where

-

  ChainSeekServer :: AcceptSocketDriverSelector RuntimeChainSeek f -> RootSelector f

-

  QueryServer :: AcceptSocketDriverSelector (Query ChainSyncQuery) f -> RootSelector f

-

  JobServer :: AcceptSocketDriverSelector (Job ChainSyncCommand) f -> RootSelector f

+

  ChainSeekServer :: AcceptSocketDriverSelector (Handshake RuntimeChainSeek) f -> RootSelector f

+

  QueryServer :: AcceptSocketDriverSelector (Handshake (Query ChainSyncQuery)) f -> RootSelector f

+

  JobServer :: AcceptSocketDriverSelector (Handshake (Job ChainSyncCommand)) f -> RootSelector f

  ConfigWatcher :: ConfigWatcherSelector f -> RootSelector f

-- TODO automate this boilerplate with Template Haskell

m

marlowe-chain-sync/chainseekd/Main.hs

+4/-4

import Logging (RootSelector(..), getRootSelectorConfig)

import Network.Protocol.ChainSeek.Codec (codecChainSeek)

import Network.Protocol.ChainSeek.Server (chainSeekServerPeer)

-

import Network.Protocol.Driver (acceptRunServerPeerOverSocketWithLogging)

+

import Network.Protocol.Handshake.Server (acceptRunServerPeerOverSocketWithLoggingWithHandshake)

import Network.Protocol.Job.Codec (codecJob)

import Network.Protocol.Job.Server (jobServerPeer)

import Network.Protocol.Query.Codec (codecQuery)

            { databaseQueries = hoistDatabaseQueries

                (either throwUsageError pure <=< Pool.use pool)

                PostgreSQL.databaseQueries

-

            , acceptRunChainSeekServer = acceptRunServerPeerOverSocketWithLogging

+

            , acceptRunChainSeekServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend ChainSeekServer eventBackend)

                throwIO

                chainSeekSocket

                codecChainSeek

                (chainSeekServerPeer Genesis)

-

            , acceptRunQueryServer = acceptRunServerPeerOverSocketWithLogging

+

            , acceptRunQueryServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend QueryServer eventBackend)

                throwIO

                querySocket

                codecQuery

                queryServerPeer

-

            , acceptRunJobServer = acceptRunServerPeerOverSocketWithLogging

+

            , acceptRunJobServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend JobServer eventBackend)

                throwIO

                commandSocket

m

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs

+22/-0

import Data.Map (Map)

import qualified Data.Map as Map

import Data.Maybe (fromJust)

+

import Data.Proxy (Proxy(..))

import Data.Set (Set)

import Data.Set.NonEmpty (NESet)

import qualified Data.Set.NonEmpty as NESet

import Network.Protocol.ChainSeek.Codec

import Network.Protocol.ChainSeek.Server

import Network.Protocol.ChainSeek.Types

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.Protocol.Job.Types (CommandToJSON)

import qualified Network.Protocol.Job.Types as Job

import qualified Network.Protocol.Query.Types as Query

  deriving stock (Show, Eq, Ord, Functor, Generic)

  deriving anyclass (Binary, ToJSON)

+

instance (HasSignature a, Signature a ~ Text) => HasSignature (WithGenesis a) where

+

  type Signature (WithGenesis a) = Text

+

  signature _ = T.intercalate " " ["WithGenesis", signature $ Proxy @a]

+

-- | A point in the chain, identified by a slot number, block header hash, and

-- block number.

type ChainPoint = WithGenesis BlockHeader

  deriving stock (Show, Eq, Ord, Generic)

  deriving anyclass (Binary, ToJSON)

+

instance HasSignature BlockHeader where

+

  type Signature BlockHeader = Text

+

  signature _ = "BlockHeader"

+

isAfter :: SlotNo -> BlockHeader -> Bool

isAfter s BlockHeader{..} = slotNo > s

  -- | Advances to the tip block. Waits if already at the tip.

  AdvanceToTip :: Move Void ()

+

instance HasSignature Move where

+

  type Signature Move = Text

+

  signature _ = "Move"

+

moveSchema :: SchemaVersion

moveSchema = SchemaVersion "move_unsafe"

  GetEraHistory :: ChainSyncQuery Void () (EraHistory CardanoMode)

  GetUTxOs :: GetUTxOsQuery -> ChainSyncQuery Void () UTxOs

+

instance HasSignature ChainSyncQuery where

+

  type Signature ChainSyncQuery = Text

+

  signature _ = "ChainSyncQuery"

+

instance Query.QueryToJSON ChainSyncQuery where

  queryToJSON = \case

    GetSecurityParameter -> String "get-security-parameter"

data ChainSyncCommand status err result where

  SubmitTx :: ScriptDataSupportedInEra era -> Tx era -> ChainSyncCommand Void String ()

+

instance HasSignature ChainSyncCommand where

+

  type Signature ChainSyncCommand = Text

+

  signature _ = "ChainSyncCommand"

+

instance CommandToJSON ChainSyncCommand where

  commandToJSON = \case

    SubmitTx _ tx -> object [ "submit-tx" .= show tx ]

m

marlowe-protocols/src/Network/Protocol/ChainSeek/Types.hs

+18/-0

import Data.Functor ((<&>))

import Data.Kind (Type)

import Data.Maybe (catMaybes)

+

import Data.Proxy (Proxy(..))

import Data.String (IsString)

import Data.Text (Text)

import qualified Data.Text as T

import qualified Data.Text.Encoding as T

import GHC.Show (showSpace)

import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))

import Network.Protocol.Driver (MessageToJSON(..))

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.TypedProtocol (PeerHasAgency(..), Protocol(..))

import Network.TypedProtocol.Codec (AnyMessageAndAgency(..))

import Test.QuickCheck (Arbitrary, Gen, arbitrary, oneof, shrink)

  -- | The terminal state of the protocol.

  StDone :: ChainSeek query point tip

+

instance

+

  ( HasSignature query

+

  , HasSignature point

+

  , HasSignature tip

+

  , Signature query ~ Text

+

  , Signature point ~ Text

+

  , Signature tip ~ Text

+

  ) => HasSignature (ChainSeek query point tip) where

+

  type Signature (ChainSeek query point tip) = Text

+

  signature _ = T.intercalate " "

+

    [ "ChainSeek"

+

    , signature $ Proxy @query

+

    , signature $ Proxy @point

+

    , signature $ Proxy @tip

+

-- | Schema version used for

newtype SchemaVersion = SchemaVersion Text

  deriving stock (Show, Eq, Ord)

m

marlowe-protocols/src/Network/Protocol/Handshake/Client.hs

+71/-15

{-# LANGUAGE DataKinds #-}

+

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs #-}

+

{-# LANGUAGE KindSignatures #-}

+

{-# LANGUAGE PolyKinds #-}

{-# LANGUAGE RankNTypes #-}

-- | A generic client for the handshake protocol. Includes a function for

module Network.Protocol.Handshake.Client

  where

+

import Control.Monad.Cleanup (MonadCleanup)

+

import Control.Monad.Trans.Control (MonadBaseControl)

+

import Data.Binary (Binary)

+

import Data.ByteString.Lazy (ByteString)

+

import Data.Proxy (Proxy(..))

+

import Network.Protocol.ChainSeek.Codec (DeserializeError)

+

import Network.Protocol.Driver (ConnectSocketDriverSelector, RunClient, ToPeer, runClientPeerOverSocketWithLogging)

+

import Network.Protocol.Handshake.Codec (codecHandshake)

import Network.Protocol.Handshake.Types

+

import Network.Socket (AddrInfo)

import Network.TypedProtocol

+

import Network.TypedProtocol.Codec (Codec)

+

import Observe.Event (EventBackend)

+

import Observe.Event.Backend (noopEventBackend)

-- | A generic client for the handshake protocol.

-

data HandshakeClient h client m a = HandshakeClient

-

  { handshake :: m h

+

data HandshakeClient sig client m a = HandshakeClient

+

  { handshake :: m sig

  , recvMsgReject :: m a

  , recvMsgAccept :: m (client m a)

  deriving Functor

-

simpleHandshakeClient :: Applicative m => h -> a -> client m a -> HandshakeClient h client m a

-

simpleHandshakeClient h a client = HandshakeClient

-

  { handshake = pure h

-

  , recvMsgReject = pure a

+

simpleHandshakeClient :: MonadFail m => sig -> client m a -> HandshakeClient sig client m a

+

simpleHandshakeClient sig client = HandshakeClient

+

  { handshake = pure sig

+

  , recvMsgReject = fail "Handshake rejected by server"

  , recvMsgAccept = pure client

+

embedClientInHandshake :: MonadFail m => sig -> RunClient m (HandshakeClient sig server) -> RunClient m server

+

embedClientInHandshake sig runClient = runClient . simpleHandshakeClient sig

+

runClientPeerOverSocketWithLoggingWithHandshake

+

  :: forall client protocol (st :: protocol) m r

+

   . ( MonadBaseControl IO m

+

     , MonadCleanup m

+

     , MonadFail m

+

     , Binary (Signature protocol)

+

     , HasSignature protocol

+

  => EventBackend m r (ConnectSocketDriverSelector (Handshake protocol))

+

  -> (forall x. DeserializeError -> m x)

+

  -> AddrInfo

+

  -> Codec protocol DeserializeError m ByteString

+

  -> ToPeer client protocol 'AsClient st m

+

  -> RunClient m client

+

runClientPeerOverSocketWithLoggingWithHandshake eventBackend throwImpl addr codec toPeer =

+

  embedClientInHandshake (signature $ Proxy @protocol) $ runClientPeerOverSocketWithLogging

+

    eventBackend

+

    throwImpl

+

    addr

+

    (codecHandshake codec)

+

    (handshakeClientPeer toPeer)

+

runClientPeerOverSocketWithHandshake

+

  :: forall client protocol (st :: protocol) m

+

   . ( MonadBaseControl IO m

+

     , MonadCleanup m

+

     , MonadFail m

+

     , Binary (Signature protocol)

+

     , HasSignature protocol

+

  => (forall x. DeserializeError -> m x)

+

  -> AddrInfo

+

  -> Codec protocol DeserializeError m ByteString

+

  -> ToPeer client protocol 'AsClient st m

+

  -> RunClient m client

+

runClientPeerOverSocketWithHandshake =

+

  runClientPeerOverSocketWithLoggingWithHandshake $ noopEventBackend ()

+

hoistHandshakeClient

  :: Functor m

  => (forall x. (forall y. m y -> n y) -> client m x -> client n x)

  -> (forall x. m x -> n x)

-

  -> HandshakeClient h client m a

-

  -> HandshakeClient h client n a

+

  -> HandshakeClient sig client m a

+

  -> HandshakeClient sig client n a

hoistHandshakeClient hoistClient f HandshakeClient{..} = HandshakeClient

  { handshake = f handshake

  , recvMsgReject = f recvMsgReject

  , recvMsgAccept = f $ hoistClient f <$> recvMsgAccept

handshakeClientPeer

-

  :: forall client m h ps st a

+

  :: forall client m ps st a

   . Functor m

  => (forall x. client m x -> Peer ps 'AsClient st m x)

-

  -> HandshakeClient h client m a

-

  -> Peer (Handshake h ps) 'AsClient ('StInit st) m a

+

  -> HandshakeClient (Signature ps) client m a

+

  -> Peer (Handshake ps) 'AsClient ('StInit st) m a

handshakeClientPeer clientPeer HandshakeClient{..} =

  Effect $ peerInit <$> handshake

  where

-

    peerInit :: h -> Peer (Handshake h ps) 'AsClient ('StInit st) m a

-

    peerInit h =

-

      Yield (ClientAgency TokInit) (MsgHandshake h) $

+

    peerInit :: Signature ps -> Peer (Handshake ps) 'AsClient ('StInit st) m a

+

    peerInit sig =

+

      Yield (ClientAgency TokInit) (MsgHandshake sig) $

      Await (ServerAgency TokHandshake) \case

        MsgReject -> Effect $ Done TokDone <$> recvMsgReject

        MsgAccept -> Effect $ liftPeer . clientPeer <$> recvMsgAccept

-

    liftPeer :: forall st'. Peer ps 'AsClient st' m a -> Peer (Handshake h ps) 'AsClient ('StLift st') m a

+

    liftPeer :: forall st'. Peer ps 'AsClient st' m a -> Peer (Handshake ps) 'AsClient ('StLift st') m a

    liftPeer = \case

      Effect m -> Effect $ liftPeer <$> m

      Done tok a -> Done (TokLiftNobody tok) a

m

marlowe-protocols/src/Network/Protocol/Handshake/Codec.hs

+24/-21

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE ExplicitNamespaces #-}

+

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE KindSignatures #-}

{-# LANGUAGE PolyKinds #-}

import Network.TypedProtocol.Codec

codecHandshake

-

  :: forall ps h m

-

   . (Monad m, Binary h)

+

  :: forall ps m

+

   . (Monad m, Binary (Signature ps))

  => Codec ps DeserializeError m LBS.ByteString

-

  -> Codec (Handshake h ps) DeserializeError m LBS.ByteString

+

  -> Codec (Handshake ps) DeserializeError m LBS.ByteString

codecHandshake (Codec encodeMsg decodeMsg) = Codec

  ( \case

    ClientAgency TokInit -> \case

-

      MsgHandshake h -> runPut do

+

      MsgHandshake sig -> runPut do

        putWord8 0x00

-

        put h

+

        put sig

    ClientAgency (TokLiftClient tok) -> \case

      MsgLift msg -> fold

        [ runPut $ putWord8 0x3

  (\tok -> decodeGet getWord8 >>= handleTag tok)

  where

    handleTag

-

      :: PeerHasAgency pr (st :: Handshake h ps)

+

      :: PeerHasAgency pr (st :: Handshake ps)

      -> DecodeStep LBS.ByteString DeserializeError m Word8

      -> m (DecodeStep LBS.ByteString DeserializeError m (SomeMessage st))

    handleTag tok = \case

      DecodeFail f -> pure $ DecodeFail f

      DecodePartial next -> pure $ DecodePartial $ handleTag tok <=< next

      DecodeDone tag mUnconsumed -> case tag of

        0x00 -> case tok of

-

          ClientAgency TokInit -> handleH <$> decodeGet get

+

          ClientAgency TokInit -> decodeSignature mUnconsumed <$> decodeGet get

          _ -> failInvalidTag "Invalid protocol state for MsgHandshake" mUnconsumed

        0x01 -> case tok of

          ServerAgency TokHandshake -> pure $ DecodeDone (SomeMessage MsgAccept) mUnconsumed

          _ -> failInvalidTag "Invalid protocol state for MsgAccept" mUnconsumed

        0x02 -> case tok of

-

          ServerAgency TokHandshake -> pure $ DecodeDone (SomeMessage MsgAccept) mUnconsumed

-

          _ -> failInvalidTag "Invalid protocol state for MsgAccept" mUnconsumed

+

          ServerAgency TokHandshake -> pure $ DecodeDone (SomeMessage MsgReject) mUnconsumed

+

          _ -> failInvalidTag "Invalid protocol state for MsgReject" mUnconsumed

        0x03 -> case tok of

-

          ClientAgency (TokLiftClient tok') -> handleMsg <$> decodeMsg (ClientAgency tok')

-

          ServerAgency (TokLiftServer tok') -> handleMsg <$> decodeMsg (ServerAgency tok')

+

          ClientAgency (TokLiftClient tok') -> handleMsg mUnconsumed <$> decodeMsg (ClientAgency tok')

+

          ServerAgency (TokLiftServer tok') -> handleMsg mUnconsumed <$> decodeMsg (ServerAgency tok')

          _ -> failInvalidTag "Invalid protocol state for MsgLift" mUnconsumed

        _ -> failInvalidTag ("Invalid msg tag " <> show tag) mUnconsumed

      where

          , unconsumedInput = foldMap toStrict mUnconsumed

-

    handleH

-

      :: DecodeStep LBS.ByteString DeserializeError m h

-

      -> DecodeStep LBS.ByteString DeserializeError m (SomeMessage ('StInit st' :: Handshake h ps))

-

    handleH = \case

+

    decodeSignature

+

      :: Maybe LBS.ByteString

+

      -> DecodeStep LBS.ByteString DeserializeError m (Signature ps)

+

      -> DecodeStep LBS.ByteString DeserializeError m (SomeMessage ('StInit st' :: Handshake ps))

+

    decodeSignature mUnconsumed = \case

      DecodeFail f -> DecodeFail f

-

      DecodePartial next -> DecodePartial $ fmap handleH <$> next

-

      DecodeDone h mUnconsumed -> DecodeDone (SomeMessage $ MsgHandshake h) mUnconsumed

+

      DecodePartial next -> DecodePartial \mUnconsumed' -> decodeSignature Nothing <$> next (mUnconsumed <> mUnconsumed')

+

      DecodeDone sig mUnconsumed' -> DecodeDone (SomeMessage $ MsgHandshake sig) $ mUnconsumed <> mUnconsumed'

    handleMsg

-

      :: DecodeStep LBS.ByteString DeserializeError m (SomeMessage st')

+

      :: Maybe LBS.ByteString

+

      -> DecodeStep LBS.ByteString DeserializeError m (SomeMessage st')

      -> DecodeStep LBS.ByteString DeserializeError m (SomeMessage ('StLift st'))

-

    handleMsg = \case

+

    handleMsg mUnconsumed = \case

      DecodeFail f -> DecodeFail f

-

      DecodePartial next -> DecodePartial $ fmap handleMsg <$> next

-

      DecodeDone (SomeMessage msg) mUnconsumed -> DecodeDone (SomeMessage $ MsgLift msg) mUnconsumed

+

      DecodePartial next -> DecodePartial \mUnconsumed' -> handleMsg Nothing <$> next (mUnconsumed <> mUnconsumed')

+

      DecodeDone (SomeMessage msg) mUnconsumed' -> DecodeDone (SomeMessage $ MsgLift msg) $ mUnconsumed <> mUnconsumed'

m

marlowe-protocols/src/Network/Protocol/Handshake/Server.hs

+76/-13

{-# LANGUAGE DataKinds #-}

+

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs #-}

+

{-# LANGUAGE KindSignatures #-}

+

{-# LANGUAGE PolyKinds #-}

{-# LANGUAGE RankNTypes #-}

-- | A generic server for the handshake protocol. Includes a function for

module Network.Protocol.Handshake.Server

  where

+

import Control.Monad.Cleanup (MonadCleanup)

+

import Control.Monad.Trans.Control (MonadBaseControl)

import Data.Bifunctor (Bifunctor(bimap))

+

import Data.Binary (Binary)

+

import Data.ByteString.Lazy (ByteString)

import Data.Functor ((<&>))

+

import Data.Proxy (Proxy(..))

+

import Network.Protocol.ChainSeek.Codec (DeserializeError)

+

import Network.Protocol.Driver

+

  (AcceptSocketDriverSelector, RunServer(..), ToPeer, acceptRunServerPeerOverSocketWithLogging)

+

import Network.Protocol.Handshake.Codec (codecHandshake)

import Network.Protocol.Handshake.Types

+

import Network.Socket (Socket)

import Network.TypedProtocol

+

import Network.TypedProtocol.Codec (Codec)

+

import Observe.Event (EventBackend)

+

import Observe.Event.Backend (noopEventBackend)

-- | A generic server for the handshake protocol.

-

newtype HandshakeServer h server m a = HandshakeServer

-

  { recvMsgHandshake :: h -> m (Either a (server m a))

+

newtype HandshakeServer sig server m a = HandshakeServer

+

  { recvMsgHandshake :: sig -> m (Either a (server m a))

-

instance (Functor m, Functor (server m)) => Functor (HandshakeServer h server m) where

+

instance (Functor m, Functor (server m)) => Functor (HandshakeServer sig server m) where

  fmap f HandshakeServer{..} = HandshakeServer

    { recvMsgHandshake = fmap (bimap f $ fmap f) . recvMsgHandshake

-

simpleHandshakeServer :: (Applicative m, Eq h) => h -> a -> server m a -> HandshakeServer h server m a

-

simpleHandshakeServer expected a server = HandshakeServer

-

  { recvMsgHandshake = \h -> pure if h == expected then Right server else Left a

+

simpleHandshakeServer :: (Eq sig, MonadFail m, Show sig) => sig -> server m a -> HandshakeServer sig server m a

+

simpleHandshakeServer expected server = HandshakeServer

+

  { recvMsgHandshake = \sig -> if sig == expected

+

      then pure $ Right server

+

      else fail $ "Rejecting handshake, " <> show sig <> " /= " <> show expected

+

embedServerInHandshake :: (Eq sig, Show sig, MonadFail m) => sig -> RunServer m (HandshakeServer sig server) -> RunServer m server

+

embedServerInHandshake sig (RunServer runServer) = RunServer $ runServer . simpleHandshakeServer sig

+

acceptRunServerPeerOverSocketWithLoggingWithHandshake

+

  :: forall server protocol (st :: protocol) m r

+

   . ( MonadBaseControl IO m

+

     , MonadCleanup m

+

     , MonadFail m

+

     , Eq (Signature protocol)

+

     , Show (Signature protocol)

+

     , Binary (Signature protocol)

+

     , HasSignature protocol

+

  => EventBackend m r (AcceptSocketDriverSelector (Handshake protocol))

+

  -> (forall x. DeserializeError -> m x)

+

  -> Socket

+

  -> Codec protocol DeserializeError m ByteString

+

  -> ToPeer server protocol 'AsServer st m

+

  -> m (RunServer m server)

+

acceptRunServerPeerOverSocketWithLoggingWithHandshake eventBackend throwImpl socket codec toPeer = do

+

  embedServerInHandshake (signature $ Proxy @protocol) <$> acceptRunServerPeerOverSocketWithLogging

+

    eventBackend

+

    throwImpl

+

    socket

+

    (codecHandshake codec)

+

    (handshakeServerPeer toPeer)

+

acceptRunServerPeerOverSocketWithHandshake

+

  :: forall server protocol (st :: protocol) m

+

   . ( MonadBaseControl IO m

+

     , MonadCleanup m

+

     , MonadFail m

+

     , Eq (Signature protocol)

+

     , Show (Signature protocol)

+

     , Binary (Signature protocol)

+

     , HasSignature protocol

+

  => (forall x. DeserializeError -> m x)

+

  -> Socket

+

  -> Codec protocol DeserializeError m ByteString

+

  -> ToPeer server protocol 'AsServer st m

+

  -> m (RunServer m server)

+

acceptRunServerPeerOverSocketWithHandshake =

+

  acceptRunServerPeerOverSocketWithLoggingWithHandshake $ noopEventBackend ()

+

hoistHandshakeServer

  :: Functor m

  => (forall x. (forall y. m y -> n y) -> server m x -> server n x)

  -> (forall x. m x -> n x)

-

  -> HandshakeServer h server m a

-

  -> HandshakeServer h server n a

+

  -> HandshakeServer sig server m a

+

  -> HandshakeServer sig server n a

hoistHandshakeServer hoistServer f HandshakeServer{..} = HandshakeServer

  { recvMsgHandshake = f . (fmap . fmap) (hoistServer f) . recvMsgHandshake

handshakeServerPeer

-

  :: forall client m h ps st a

+

  :: forall client m ps st a

   . Functor m

  => (forall x. client m x -> Peer ps 'AsServer st m x)

-

  -> HandshakeServer h client m a

-

  -> Peer (Handshake h ps) 'AsServer ('StInit st) m a

+

  -> HandshakeServer (Signature ps) client m a

+

  -> Peer (Handshake ps) 'AsServer ('StInit st) m a

handshakeServerPeer serverPeer HandshakeServer{..} =

  Await (ClientAgency TokInit) \case

-

    MsgHandshake h -> Effect $ recvMsgHandshake h <&> \case

+

    MsgHandshake sig -> Effect $ recvMsgHandshake sig <&> \case

      Left a ->

        Yield (ServerAgency TokHandshake) MsgReject $ Done TokDone a

      Right server ->

        Yield (ServerAgency TokHandshake) MsgAccept $ liftPeer $ serverPeer server

  where

-

    liftPeer :: forall st'. Peer ps 'AsServer st' m a -> Peer (Handshake h ps) 'AsServer ('StLift st') m a

+

    liftPeer :: forall st'. Peer ps 'AsServer st' m a -> Peer (Handshake ps) 'AsServer ('StLift st') m a

    liftPeer = \case

      Effect m -> Effect $ liftPeer <$> m

      Done tok a -> Done (TokLiftNobody tok) a

m

marlowe-protocols/src/Network/Protocol/Handshake/Types.hs

+27/-20

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE EmptyCase #-}

+

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE GADTs #-}

{-# LANGUAGE KindSignatures #-}

{-# LANGUAGE PolyKinds #-}

{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE TypeOperators #-}

+

{-# LANGUAGE UndecidableInstances #-}

-- | The type of the handshake protocol.

--

  where

import Data.Aeson (ToJSON, Value(..), object, (.=))

+

import Data.Proxy (Proxy)

import GHC.Show (showSpace)

import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))

import Network.Protocol.Driver (MessageToJSON(..))

import Network.TypedProtocol

import Network.TypedProtocol.Codec (AnyMessageAndAgency(..))

import Test.QuickCheck (Arbitrary(arbitrary), oneof, shrink)

-

data Handshake h ps where

-

  StInit :: ps -> Handshake h ps

-

  StHandshake :: ps -> Handshake h ps

-

  StLift :: ps -> Handshake h ps

-

  StDone :: Handshake h ps

+

data Handshake ps where

+

  StInit :: ps -> Handshake ps

+

  StHandshake :: ps -> Handshake ps

+

  StLift :: ps -> Handshake ps

+

  StDone :: Handshake ps

-

instance Protocol ps => Protocol (Handshake h ps) where

-

  data Message (Handshake h ps) st st' where

-

    MsgHandshake :: h -> Message (Handshake h ps)

+

class HasSignature (ps :: k) where

+

  type Signature ps :: *

+

  signature :: Proxy ps -> Signature ps

+

instance Protocol ps => Protocol (Handshake ps) where

+

  data Message (Handshake ps) st st' where

+

    MsgHandshake :: Signature ps -> Message (Handshake ps)

      ('StInit st)

      ('StHandshake st)

-

    MsgAccept :: Message (Handshake h ps)

+

    MsgAccept :: Message (Handshake ps)

      ('StHandshake st)

      ('StLift st)

-

    MsgReject :: Message (Handshake h ps)

+

    MsgReject :: Message (Handshake ps)

      ('StHandshake st)

      'StDone

-

    MsgLift :: Message ps st st' -> Message (Handshake h ps)

+

    MsgLift :: Message ps st st' -> Message (Handshake ps)

      ('StLift st)

      ('StLift st')

    TokLiftNobody n_tok -> \case

      TokLiftServer s_tok -> exclusionLemma_NobodyAndServerHaveAgency n_tok s_tok

-

instance (ArbitraryMessage ps, Arbitrary h) => ArbitraryMessage (Handshake h ps) where

+

instance (ArbitraryMessage ps, Arbitrary (Signature ps)) => ArbitraryMessage (Handshake ps) where

  arbitraryMessage = oneof

    [ AnyMessageAndAgency (ClientAgency TokInit) . MsgHandshake <$> arbitrary

    , pure $ AnyMessageAndAgency (ServerAgency TokHandshake) MsgReject

  shrinkMessage = \case

    ClientAgency TokInit -> \case

-

      MsgHandshake h -> MsgHandshake <$> shrink h

+

      MsgHandshake sig -> MsgHandshake <$> shrink sig

    ClientAgency (TokLiftClient tok) -> \case

      MsgLift msg -> MsgLift <$> shrinkMessage (ClientAgency tok) msg

    ServerAgency TokHandshake -> const []

    ServerAgency (TokLiftServer tok) -> \case

      MsgLift msg -> MsgLift <$> shrinkMessage (ServerAgency tok) msg

-

instance (MessageEq ps, Eq h) => MessageEq (Handshake h ps) where

+

instance (MessageEq ps, Eq (Signature ps)) => MessageEq (Handshake ps) where

  messageEq (AnyMessageAndAgency tok1 msg1) (AnyMessageAndAgency tok2 msg2)= case (tok1, tok2) of

    (ClientAgency TokInit, ClientAgency TokInit) -> case (msg1, msg2) of

-

      (MsgHandshake h, MsgHandshake h') -> h == h'

+

      (MsgHandshake sig, MsgHandshake sig') -> sig == sig'

    (ClientAgency TokInit, _) -> False

    (ClientAgency (TokLiftClient tok1'), ClientAgency (TokLiftClient tok2')) -> case (msg1, msg2) of

      (MsgLift msg1', MsgLift msg2') ->

        messageEq (AnyMessageAndAgency (ServerAgency tok1') msg1') (AnyMessageAndAgency (ServerAgency tok2') msg2')

    (ServerAgency (TokLiftServer _), _) -> False

-

instance (ShowProtocol ps, Show h) => ShowProtocol (Handshake h ps) where

+

instance (ShowProtocol ps, Show (Signature ps)) => ShowProtocol (Handshake ps) where

  showsPrecMessage p tok = \case

-

    MsgHandshake h -> showParen (p >= 11)

+

    MsgHandshake sig -> showParen (p >= 11)

      ( showString "MsgHandshake"

      . showSpace

-

      . showsPrec 11 h

+

      . showsPrec 11 sig

    MsgAccept -> showString "MsgAccept"

    MsgReject -> showString "MsgReject"

      . showsPrecClientHasAgency 11 tok

-

instance (MessageToJSON ps, ToJSON h) => MessageToJSON (Handshake h ps) where

+

instance (MessageToJSON ps, ToJSON (Signature ps)) => MessageToJSON (Handshake ps) where

  messageToJSON = \case

    ClientAgency TokInit -> \case

-

      MsgHandshake h -> object [ "handshake" .= h ]

+

      MsgHandshake sig -> object [ "handshake" .= sig ]

    ClientAgency (TokLiftClient tok) -> \case

      MsgLift msg -> object [ "lift" .= messageToJSON (ClientAgency tok) msg ]

    ServerAgency TokHandshake -> String . \case

m

marlowe-protocols/src/Network/Protocol/Job/Types.hs

+8/-0

import Data.Binary.Get (Get)

import Data.Functor ((<&>))

import Data.Maybe (catMaybes)

+

import Data.Proxy (Proxy(..))

+

import Data.Text (Text)

+

import qualified Data.Text as T

import Data.Type.Equality (type (:~:)(Refl))

import GHC.Show (showSpace)

import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))

import Network.Protocol.Driver (MessageToJSON(..))

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.TypedProtocol

import Network.TypedProtocol.Codec (AnyMessageAndAgency(..))

import Test.QuickCheck (Gen, oneof)

  -- | The terminal state of the protocol.

  StDone :: Job cmd

+

instance (HasSignature cmd, Signature cmd ~ Text) => HasSignature (Job cmd) where

+

  type Signature (Job cmd) = Text

+

  signature _ = T.intercalate " " ["Job", signature $ Proxy @cmd]

+

instance Protocol (Job cmd) where

  -- | The type of messages in the protocol. Corresponds to state transition in

m

marlowe-protocols/src/Network/Protocol/Query/Types.hs

+8/-0

import Data.Data (type (:~:)(Refl))

import Data.Functor ((<&>))

import Data.Maybe (catMaybes)

+

import Data.Proxy (Proxy(..))

+

import Data.Text (Text)

+

import qualified Data.Text as T

import GHC.Show (showSpace)

import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))

import Network.Protocol.Driver (MessageToJSON(..))

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.TypedProtocol

import Network.TypedProtocol.Codec (AnyMessageAndAgency(..))

import Test.QuickCheck (Gen, oneof)

  -- | The terminal state of the protocol.

  StDone :: Query query

+

instance (HasSignature query, Signature query ~ Text) => HasSignature (Query query) where

+

  type Signature (Query query) = Text

+

  signature _ = T.intercalate " " ["Query", signature $ Proxy @query]

+

data StNextKind

  = CanReject

  | MustReply

m

marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command.hs

+15/-5

{-# LANGUAGE DataKinds #-}

+

{-# LANGUAGE FlexibleContexts #-}

+

{-# LANGUAGE KindSignatures #-}

+

{-# LANGUAGE PolyKinds #-}

{-# LANGUAGE RankNTypes #-}

module Language.Marlowe.Runtime.CLI.Command

  where

import Control.Concurrent.STM (STM)

-

import Control.Exception (Exception, SomeException, catch, throw)

+

import Control.Exception (SomeException, catch, throw)

import Control.Exception.Base (throwIO)

import Control.Monad.Trans.Reader (runReaderT)

+

import Data.Binary (Binary)

import qualified Data.ByteString.Lazy as LB

import Data.Foldable (asum)

import Language.Marlowe.Protocol.Sync.Client (marloweSyncClientPeer)

import Language.Marlowe.Runtime.CLI.Monad (CLI, runCLI)

import Language.Marlowe.Runtime.CLI.Option (optParserWithEnvDefault)

import qualified Language.Marlowe.Runtime.CLI.Option as O

-

import Network.Protocol.Driver (RunClient, runClientPeerOverSocket)

+

import Network.Protocol.ChainSeek.Codec (DeserializeError)

+

import Network.Protocol.Driver (RunClient)

+

import Network.Protocol.Handshake.Client (runClientPeerOverSocketWithHandshake)

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.Protocol.Job.Client (jobClientPeer)

import Network.Protocol.Job.Codec (codecJob)

import Network.Socket (AddrInfo, HostName, PortNumber, SocketType(..), addrSocketType, defaultHints, getAddrInfo)

      head <$> getAddrInfo (Just defaultHints { addrSocketType = Stream }) (Just host) (Just $ show port)

runClientPeerOverSocket'

-

  :: Exception ex

+

  :: forall protocol client (st :: protocol)

+

   . ( Binary (Signature protocol)

+

     , HasSignature protocol

+

  => String -- ^ Client failure stderr extra message

  -> AddrInfo -- ^ Socket address to connect to

-

  -> Codec protocol ex IO LB.ByteString -- ^ A codec for the protocol

+

  -> Codec protocol DeserializeError IO LB.ByteString -- ^ A codec for the protocol

  -> (forall a. client IO a -> Peer protocol 'AsClient st IO a) -- ^ Interpret the client as a protocol peer

  -> RunClient IO client

runClientPeerOverSocket' errMsg addr codec clientToPeer client = do

let

-

    run = runClientPeerOverSocket throwIO addr codec clientToPeer client

+

    run = runClientPeerOverSocketWithHandshake throwIO addr codec clientToPeer client

  run `catch` \(err :: SomeException)-> do

    hPutStrLn stderr errMsg

    throw err

m

marlowe-runtime/discovery-api/Language/Marlowe/Protocol/HeaderSync/Types.hs

+6/-0

  where

import Data.Aeson (Value(..), object, (.=))

+

import Data.Text (Text)

import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint)

import Language.Marlowe.Runtime.Discovery.Api (ContractHeader)

import Network.Protocol.Driver (MessageToJSON(..))

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.TypedProtocol (PeerHasAgency(..), Protocol(..))

data MarloweHeaderSync where

  StWait :: MarloweHeaderSync

  StDone :: MarloweHeaderSync

+

instance HasSignature MarloweHeaderSync where

+

  type Signature MarloweHeaderSync = Text

+

  signature _ = "MarloweSync"

+

instance Protocol MarloweHeaderSync where

  data Message MarloweHeaderSync from to where

    MsgIntersect :: [BlockHeader] -> Message MarloweHeaderSync

m

marlowe-runtime/discovery-api/Language/Marlowe/Runtime/Discovery/Api.hs

+6/-0

import Data.Aeson (ToJSON(..), Value(..), object, (.=))

import Data.Binary (Binary, get, getWord8, put, putWord8)

+

import Data.Text (Text)

import Data.Type.Equality (type (:~:)(Refl))

import Data.Void (Void, absurd)

import GHC.Generics (Generic)

import Language.Marlowe.Runtime.ChainSync.Api (Address, BlockHeader, PolicyId, ScriptHash, TransactionMetadata)

import Language.Marlowe.Runtime.Core.Api (ContractId, SomeMarloweVersion)

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.Protocol.Query.Types (IsQuery(..), QueryToJSON(..), SomeTag(..))

-- | A Marlowe contract header is a compact structure that contains all the

  -- tokens.

  GetContractHeadersByRoleTokenCurrency :: PolicyId -> DiscoveryQuery Void Void [ContractHeader]

+

instance HasSignature DiscoveryQuery where

+

  type Signature DiscoveryQuery = Text

+

  signature _ = "DiscoveryQuery"

+

instance QueryToJSON DiscoveryQuery where

  queryToJSON = \case

    GetContractHeaders -> String "get-contract-headers"

m

marlowe-runtime/history-api/Language/Marlowe/Protocol/Sync/Types.hs

+6/-0

  where

import Data.Aeson (Key, ToJSON, Value(..), object, (.=))

+

import Data.Text (Text)

import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader)

import Language.Marlowe.Runtime.Core.Api (ContractId(..), MarloweVersion(..), MarloweVersionTag)

import Language.Marlowe.Runtime.History.Api

import Network.Protocol.Driver (MessageToJSON(..))

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.TypedProtocol (PeerHasAgency(..), Protocol(..))

data MarloweSync where

  StWait :: MarloweVersionTag -> MarloweSync

  StIntersect :: MarloweVersionTag -> MarloweSync

+

instance HasSignature MarloweSync where

+

  type Signature MarloweSync = Text

+

  signature _ = "MarloweSync"

+

instance Protocol MarloweSync where

  data Message MarloweSync from to where

    MsgFollowContract :: ContractId -> Message MarloweSync

m

marlowe-runtime/history-api/Language/Marlowe/Runtime/History/Api.hs

+10/-0

import qualified Data.Map as Map

import Data.Maybe (mapMaybe)

import Data.Set (Set)

+

import Data.Text (Text)

import Data.Traversable (for)

import Data.Type.Equality (type (:~:)(Refl))

import Data.Void (Void, absurd)

import Language.Marlowe.Runtime.Core.ScriptRegistry (MarloweScripts(..), getMarloweVersion)

import qualified Language.Marlowe.Scripts as V1

import Network.Protocol.ChainSeek.Codec (DeserializeError)

+

import Network.Protocol.Handshake.Types (HasSignature(..))

import Network.Protocol.Job.Client

import Network.Protocol.Job.Codec

import Network.Protocol.Job.Server

  FollowContract :: ContractId -> HistoryCommand Void ContractHistoryError Bool

  StopFollowingContract :: ContractId -> HistoryCommand Void Void Bool

+

instance HasSignature HistoryCommand where

+

  type Signature HistoryCommand = Text

+

  signature _ = "HistoryCommand"

+

instance CommandToJSON HistoryCommand where

  commandToJSON = \case

    FollowContract contractId -> object [ "follow-contract" .= contractId ]

  GetFollowedContracts :: HistoryQuery ContractId Void (Map ContractId FollowerStatus)

  GetStatuses :: Set ContractId -> HistoryQuery Void Void (Map ContractId FollowerStatus)

+

instance HasSignature HistoryQuery where

+

  type Signature HistoryQuery = Text

+

  signature _ = "HistoryQuery"

+

instance Query.QueryToJSON HistoryQuery where

  queryToJSON = \case

    GetFollowedContracts -> String "get-followed-contracts"

m

marlowe-runtime/marlowe-discovery/Logging.hs

+4/-3

  , getAcceptSocketDriverSelectorConfig

  , getConnectSocketDriverSelectorConfig

+

import Network.Protocol.Handshake.Types (Handshake)

import Network.Protocol.Query.Types (Query)

import Observe.Event.Component

  (ConfigWatcherSelector(ReloadConfig), GetSelectorConfig, SelectorConfig(..), prependKey, singletonFieldConfig)

data RootSelector f where

-

  ChainSeekClient :: ConnectSocketDriverSelector RuntimeChainSeek f -> RootSelector f

-

  QueryServer :: AcceptSocketDriverSelector (Query DiscoveryQuery) f -> RootSelector f

-

  SyncServer :: AcceptSocketDriverSelector MarloweHeaderSync f -> RootSelector f

+

  ChainSeekClient :: ConnectSocketDriverSelector (Handshake RuntimeChainSeek) f -> RootSelector f

+

  QueryServer :: AcceptSocketDriverSelector (Handshake (Query DiscoveryQuery)) f -> RootSelector f

+

  SyncServer :: AcceptSocketDriverSelector (Handshake MarloweHeaderSync) f -> RootSelector f

  -- App :: ChainSyncSelector f -> RootSelector f

  ConfigWatcher :: ConfigWatcherSelector f -> RootSelector f

m

marlowe-runtime/marlowe-discovery/Main.hs

+5/-4

import Language.Marlowe.Runtime.Discovery (DiscoveryDependencies(..), discovery)

import Logging (RootSelector(..), getRootSelectorConfig)

import Network.Protocol.ChainSeek.Client (chainSeekClientPeer)

-

import Network.Protocol.Driver (acceptRunServerPeerOverSocketWithLogging, runClientPeerOverSocketWithLogging)

+

import Network.Protocol.Handshake.Client (runClientPeerOverSocketWithLoggingWithHandshake)

+

import Network.Protocol.Handshake.Server (acceptRunServerPeerOverSocketWithLoggingWithHandshake)

import Network.Protocol.Query.Codec (codecQuery)

import Network.Protocol.Query.Server (queryServerPeer)

import Network.Socket

            connectToChainSeek :: forall a. RuntimeChainSeekClient IO a -> IO a

            connectToChainSeek client = do

              addr' <- head <$> getAddrInfo (Just clientHints) (Just chainSeekHost) (Just $ show chainSeekPort)

-

              runClientPeerOverSocketWithLogging

+

              runClientPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend ChainSeekClient eventBackend)

                throwIO

                addr'

                runtimeChainSeekCodec

                (chainSeekClientPeer Genesis)

                client

-

            acceptRunQueryServer = acceptRunServerPeerOverSocketWithLogging

+

            acceptRunQueryServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

              (narrowEventBackend QueryServer eventBackend)

              throwIO

              querySocket

              codecQuery

              queryServerPeer

-

            acceptRunSyncServer = acceptRunServerPeerOverSocketWithLogging

+

            acceptRunSyncServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

              (narrowEventBackend SyncServer eventBackend)

              throwIO

              syncSocket

m

marlowe-runtime/marlowe-history/Logging.hs

+5/-4

  , getAcceptSocketDriverSelectorConfig

  , getConnectSocketDriverSelectorConfig

+

import Network.Protocol.Handshake.Types (Handshake)

import Network.Protocol.Job.Types (Job)

import Network.Protocol.Query.Types (Query)

import Observe.Event.Component

  (ConfigWatcherSelector(ReloadConfig), GetSelectorConfig, SelectorConfig(..), prependKey, singletonFieldConfig)

data RootSelector f where

-

  ChainSeekClient :: ConnectSocketDriverSelector RuntimeChainSeek f -> RootSelector f

-

  QueryServer :: AcceptSocketDriverSelector (Query HistoryQuery) f -> RootSelector f

-

  JobServer :: AcceptSocketDriverSelector (Job HistoryCommand) f -> RootSelector f

-

  SyncServer :: AcceptSocketDriverSelector MarloweSync f -> RootSelector f

+

  ChainSeekClient :: ConnectSocketDriverSelector (Handshake RuntimeChainSeek) f -> RootSelector f

+

  QueryServer :: AcceptSocketDriverSelector (Handshake (Query HistoryQuery)) f -> RootSelector f

+

  JobServer :: AcceptSocketDriverSelector (Handshake (Job HistoryCommand)) f -> RootSelector f

+

  SyncServer :: AcceptSocketDriverSelector (Handshake MarloweSync) f -> RootSelector f

  -- App :: ChainSyncSelector f -> RootSelector f

  ConfigWatcher :: ConfigWatcherSelector f -> RootSelector f

m

marlowe-runtime/marlowe-history/Main.hs

+13/-7

import Control.Concurrent.STM (atomically)

import Control.Exception (bracket, bracketOnError, throwIO)

import Data.Either (fromRight)

+

import Data.Text (Text)

import qualified Data.Text.Lazy.IO as TL

import Data.UUID.V4 (nextRandom)

import Data.Void (Void)

import Language.Marlowe.Runtime.History.Store.Memory (mkHistoryQueriesInMemory)

import Logging (RootSelector(..), getRootSelectorConfig)

import Network.Protocol.ChainSeek.Client (chainSeekClientPeer)

-

import Network.Protocol.Driver

-

  (acceptRunServerPeerOverSocketWithLogging, runClientPeerOverSocket, runClientPeerOverSocketWithLogging)

+

import Network.Protocol.Driver (runClientPeerOverSocket)

+

import Network.Protocol.Handshake.Client

+

  (handshakeClientPeer, runClientPeerOverSocketWithLoggingWithHandshake, simpleHandshakeClient)

+

import Network.Protocol.Handshake.Codec (codecHandshake)

+

import Network.Protocol.Handshake.Server (acceptRunServerPeerOverSocketWithLoggingWithHandshake)

import Network.Protocol.Job.Server (jobServerPeer)

import Network.Protocol.Query.Client (liftQuery, queryClientPeer)

import Network.Protocol.Query.Codec (codecQuery)

              connectToChainSeek :: forall a. RuntimeChainSeekClient IO a -> IO a

              connectToChainSeek client = do

                addr' <- head <$> getAddrInfo (Just clientHints) (Just chainSeekHost) (Just $ show chainSeekPort)

-

                runClientPeerOverSocketWithLogging

+

                runClientPeerOverSocketWithLoggingWithHandshake

                  (narrowEventBackend ChainSeekClient eventBackend)

                  throwIO

                  addr'

                  runtimeChainSeekCodec

                  (chainSeekClientPeer Genesis)

                  client

-

              acceptRunJobServer = acceptRunServerPeerOverSocketWithLogging

+

              acceptRunJobServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend JobServer eventBackend)

                throwIO

                jobSocket

                historyJobCodec

                jobServerPeer

-

              acceptRunQueryServer = acceptRunServerPeerOverSocketWithLogging

+

              acceptRunQueryServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend QueryServer eventBackend)

                throwIO

                querySocket

                historyQueryCodec

                queryServerPeer

-

              acceptRunSyncServer = acceptRunServerPeerOverSocketWithLogging

+

              acceptRunSyncServer = acceptRunServerPeerOverSocketWithLoggingWithHandshake

                (narrowEventBackend SyncServer eventBackend)

                throwIO

                syncSocket

    queryChainSeek :: ChainSyncQuery Void e a -> IO (Either e a)

    queryChainSeek query = do

      addr <- head <$> getAddrInfo (Just clientHints) (Just chainSeekHost) (Just $ show chainSeekQueryPort)

-

      runClientPeerOverSocket throwIO addr codecQuery queryClientPeer $ liftQuery query

+

      runClientPeerOverSocket throwIO addr (codecHandshake codecQuery) (handshakeClientPeer queryClientPeer)

+

        $ simpleHandshakeClient @_ @Text "Query ChainSyncQuery"

+

        $ liftQuery query

    queryChainSync :: ChainSyncQuery Void e a -> IO a

    queryChainSync = fmap (fromRight $ error "failed to query chain seek server") . queryChainSeek

m

marlowe-runtime/marlowe-indexer/Logging.hs

+3/-2

Diff too large – View on GitHub

3,562 commits this week Mar 25, 2023 - Apr 01, 2023

Showing 25 of 3562 recent commits.

Yesterday's Report

New Repo Discovered

New Releases