tmp

ekg-forward.cabal

@@ -47,8 +47,11 @@ library
                        System.Metrics.Forwarder
 
   other-modules:       System.Metrics.Internal.Protocol.Type
+                       System.Metrics.Internal.Protocol.Client
+                       System.Metrics.Internal.Protocol.Server
 
-  build-depends:       typed-protocols
+  build-depends:       io-sim-classes
+                       typed-protocols
 
 test-suite ekg-forward-test
   import:              common-options

src/System/Metrics/Internal/Protocol/Client.hs

@@ -0,0 +1,187 @@
+{- |
+Copyright: (c) 2021 Input Output (Hong Kong) Ltd.
+Maintainer: Denis Shevchenko <denis.shevchenko@iohk.io>
+
+See README for more info
+-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | A view of the EKG forwarding/accepting protocol from the point of view of the
+-- client.
+--
+-- This provides a view that uses less complex types and should be easier to
+-- use than the underlying typed protocol itself.
+--
+-- For execution, a conversion into the typed protocol is provided.
+--
+module System.Metrics.Internal.Protocol.Client (
+    -- * Protocol type for the client
+    -- | The protocol states from the point of view of the client.
+    ChainSyncClient(..)
+  , ClientStIdle(..)
+  , ClientStNext(..)
+
+    -- * Execution as a typed protocol
+  , chainSyncClientPeer
+
+    -- * Null chain sync client
+  , chainSyncClientNull
+
+    -- * Utilities
+  , mapChainSyncClient
+  ) where
+
+import Control.Monad (forever)
+import Control.Monad.Class.MonadTimer
+
+import Network.TypedProtocol.Core
+
+import System.Metrics.Internal.Protocol.Type
+
+-- | A chain sync protocol client, on top of some effect 'm'.
+-- The first choice of request is within that 'm'.
+newtype ChainSyncClient header point tip m a = ChainSyncClient {
+    runChainSyncClient :: m (ClientStIdle header point tip m a)
+  }
+
+-- | A chain sync client which never sends any message.
+--
+chainSyncClientNull :: MonadTimer m => ChainSyncClient header point tip m a
+chainSyncClientNull = ChainSyncClient $ forever $ threadDelay 43200 {- one day in seconds -}
+
+{-# DEPRECATED chainSyncClientNull "Use Ouroboros.Network.NodeToClient.chainSyncPeerNull" #-}
+
+-- | In the 'StIdle' protocol state, the server does not have agency and can choose to
+-- send a request next, or a find intersection message.
+--
+data ClientStIdle header point tip m a where
+
+  -- | Send the 'MsgRequestNext', with handlers for the replies.
+  --
+  -- The handlers for this message are more complicated than most RPCs because
+  -- the server can either send us a reply immediately or it can send us a
+  -- 'MsgAwaitReply' to indicate that the server itself has to block for a
+  -- state change before it can send us the reply.
+  --
+  -- In the waiting case, the client gets the chance to take a local action.
+  --
+  SendMsgRequestNext
+    ::    ClientStNext header point tip m a
+    -> m (ClientStNext header point tip m a) -- after MsgAwaitReply
+    -> ClientStIdle header point tip m a
+
+  -- | The client decided to end the protocol.
+  --
+  SendMsgDone
+    :: a
+    -> ClientStIdle header point tip m a
+
+-- | In the 'StNext' protocol state, the client does not have agency and is
+-- waiting to receive either
+--
+--  * a roll forward,
+--  * roll back message,
+--
+-- It must be prepared to handle any of these.
+--
+data ClientStNext header point tip m a =
+     ClientStNext {
+       recvMsgRollForward  :: header -- header to add to the chain
+                           -> tip    -- information about tip of the chain
+                           -> ChainSyncClient header point tip m a,
+
+       recvMsgRollBackward :: point        -- rollback point
+                           -> tip          -- information about tip of the chain
+                           -> ChainSyncClient header point tip m a
+     }
+
+-- | Transform a 'ChainSyncClient' by mapping over the tx header and the
+-- chain tip values.
+--
+-- Note the direction of the individual mapping functions corresponds to
+-- whether the types are used as protocol inputs or outputs (or both, as is
+-- the case for points).
+--
+mapChainSyncClient :: forall header header' point point' tip tip' m a.
+                      Functor m
+                   => (point  -> point')
+                   -> (point' -> point)
+                   -> (header' -> header)
+                   -> (tip' -> tip)
+                   -> ChainSyncClient header  point  tip  m a
+                   -> ChainSyncClient header' point' tip' m a
+mapChainSyncClient fpoint fpoint' fheader ftip =
+    goClient
+  where
+    goClient :: ChainSyncClient header  point  tip  m a
+             -> ChainSyncClient header' point' tip' m a
+    goClient (ChainSyncClient c) = ChainSyncClient (fmap goIdle c)
+
+    goIdle :: ClientStIdle header  point  tip  m a
+           -> ClientStIdle header' point' tip' m a
+    goIdle (SendMsgRequestNext stNext stAwait) =
+      SendMsgRequestNext (goNext stNext) (fmap goNext stAwait)
+
+    goIdle (SendMsgDone a) = SendMsgDone a
+
+    goNext :: ClientStNext header  point  tip  m a
+           -> ClientStNext header' point' tip' m a
+    goNext ClientStNext{recvMsgRollForward, recvMsgRollBackward} =
+      ClientStNext {
+        recvMsgRollForward  = \hdr tip ->
+          goClient (recvMsgRollForward (fheader hdr) (ftip tip)),
+
+        recvMsgRollBackward = \pt  tip ->
+          goClient (recvMsgRollBackward (fpoint' pt) (ftip tip))
+      }
+
+-- | Interpret a 'ChainSyncClient' action sequence as a 'Peer' on the client
+-- side of the 'ChainSyncProtocol'.
+--
+chainSyncClientPeer
+  :: forall header point tip m a .
+     Monad m
+  => ChainSyncClient header point tip m a
+  -> Peer (ChainSync header point tip) AsClient StIdle m a
+chainSyncClientPeer (ChainSyncClient mclient) =
+    Effect $ fmap chainSyncClientPeer_ mclient
+  where
+    chainSyncClientPeer_
+      :: ClientStIdle header point tip m a
+      -> Peer (ChainSync header point tip) AsClient StIdle m a
+    chainSyncClientPeer_ (SendMsgRequestNext stNext stAwait) =
+        Yield (ClientAgency TokIdle) MsgRequestNext $
+        Await (ServerAgency (TokNext TokCanAwait)) $ \resp ->
+        case resp of
+          MsgRollForward header tip ->
+              chainSyncClientPeer (recvMsgRollForward header tip)
+            where
+              ClientStNext{recvMsgRollForward} = stNext
+
+          MsgRollBackward pRollback tip ->
+              chainSyncClientPeer (recvMsgRollBackward pRollback tip)
+            where
+              ClientStNext{recvMsgRollBackward} = stNext
+
+          -- This code could be factored more easily by changing the protocol type
+          -- to put both roll forward and back under a single constructor.
+          MsgAwaitReply ->
+            Effect $ do
+              ClientStNext{recvMsgRollForward, recvMsgRollBackward} <- stAwait
+              pure $ Await (ServerAgency (TokNext TokMustReply)) $ \resp' ->
+                case resp' of
+                  MsgRollForward header tip ->
+                    chainSyncClientPeer (recvMsgRollForward header tip)
+                  MsgRollBackward pRollback tip ->
+                    chainSyncClientPeer (recvMsgRollBackward pRollback tip)
+
+    chainSyncClientPeer_ (SendMsgDone a) =
+      Yield (ClientAgency TokIdle) MsgDone (Done TokDone a)

src/System/Metrics/Internal/Protocol/Server.hs

@@ -0,0 +1,20 @@
+{- |
+Copyright: (c) 2021 Input Output (Hong Kong) Ltd.
+Maintainer: Denis Shevchenko <denis.shevchenko@iohk.io>
+
+See README for more info
+-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module System.Metrics.Internal.Protocol.Server (
+  ) where
+
+