{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Network.Protocol.ChainSync.Examples
  ( chainSyncClientExample
  , Client (..)
  , pureClient
  , controlledClient
  , Tip (..)
  , chainSyncServerExample
  ) where

import Control.Concurrent.Class.MonadSTM.Strict

import Ouroboros.Network.Block (HasHeader (..), HeaderHash, Tip (..), castPoint,
           castTip, genesisPoint)
import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM)
import Ouroboros.Network.Mock.Chain (Chain (..), ChainUpdate (..), Point (..))
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ProducerState (ChainProducerState, FollowerId)
import Ouroboros.Network.Mock.ProducerState qualified as ChainProducerState
import Ouroboros.Network.Protocol.ChainSync.Client
import Ouroboros.Network.Protocol.ChainSync.Server

data Client header point tip m t = Client
  { forall header point tip (m :: * -> *) t.
Client header point tip m t
-> point -> tip -> m (Either t (Client header point tip m t))
rollbackward :: point -> tip -> m (Either t (Client header point tip m t))
  , forall header point tip (m :: * -> *) t.
Client header point tip m t
-> header -> m (Either t (Client header point tip m t))
rollforward  :: header -> m (Either t (Client header point tip m t))
  , forall header point tip (m :: * -> *) t.
Client header point tip m t
-> [point] -> m (Either t (Client header point tip m t))
points       :: [point] -> m (Either t (Client header point tip m t))
  }

-- | A client which doesn't do anything and never ends. Used with
-- 'chainSyncClientExample', the StrictTVar m (Chain header) will be updated but
-- nothing further will happen.
pureClient :: Applicative m => Client header point tip m void
pureClient :: forall (m :: * -> *) header point tip void.
Applicative m =>
Client header point tip m void
pureClient = Client
  { rollbackward :: point -> tip -> m (Either void (Client header point tip m void))
rollbackward = \point
_ tip
_ -> Either void (Client header point tip m void)
-> m (Either void (Client header point tip m void))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m void
-> Either void (Client header point tip m void)
forall a b. b -> Either a b
Right Client header point tip m void
forall (m :: * -> *) header point tip void.
Applicative m =>
Client header point tip m void
pureClient)
  , rollforward :: header -> m (Either void (Client header point tip m void))
rollforward  = \header
_ -> Either void (Client header point tip m void)
-> m (Either void (Client header point tip m void))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m void
-> Either void (Client header point tip m void)
forall a b. b -> Either a b
Right Client header point tip m void
forall (m :: * -> *) header point tip void.
Applicative m =>
Client header point tip m void
pureClient)
  , points :: [point] -> m (Either void (Client header point tip m void))
points       = \[point]
_ -> Either void (Client header point tip m void)
-> m (Either void (Client header point tip m void))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m void
-> Either void (Client header point tip m void)
forall a b. b -> Either a b
Right Client header point tip m void
forall (m :: * -> *) header point tip void.
Applicative m =>
Client header point tip m void
pureClient)
  }

controlledClient :: MonadSTM m
                 => ControlMessageSTM m
                 -> Client header point tip m ()
controlledClient :: forall (m :: * -> *) header point tip.
MonadSTM m =>
ControlMessageSTM m -> Client header point tip m ()
controlledClient ControlMessageSTM m
controlMessageSTM = Client header point tip m ()
go
  where
    go :: Client header point tip m ()
go = Client
      { rollbackward :: point -> tip -> m (Either () (Client header point tip m ()))
rollbackward = \point
_ tip
_ -> do
          ctrl <- ControlMessageSTM m -> m ControlMessage
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ControlMessageSTM m
controlMessageSTM
          case ctrl of
            ControlMessage
Continue  -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m ()
-> Either () (Client header point tip m ())
forall a b. b -> Either a b
Right Client header point tip m ()
go)
            ControlMessage
Quiesce   -> [Char] -> m (Either () (Client header point tip m ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Ouroboros.Network.Protocol.ChainSync.Examples.controlledClient: unexpected Quiesce"
            ControlMessage
Terminate -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either () (Client header point tip m ())
forall a b. a -> Either a b
Left ())
      , rollforward :: header -> m (Either () (Client header point tip m ()))
rollforward = \header
_ -> do
          ctrl <- ControlMessageSTM m -> m ControlMessage
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ControlMessageSTM m
controlMessageSTM
          case ctrl of
            ControlMessage
Continue  -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m ()
-> Either () (Client header point tip m ())
forall a b. b -> Either a b
Right Client header point tip m ()
go)
            ControlMessage
Quiesce   -> [Char] -> m (Either () (Client header point tip m ()))
forall a. HasCallStack => [Char] -> a
error [Char]
"Ouroboros.Network.Protocol.ChainSync.Examples.controlledClient: unexpected Quiesce"
            ControlMessage
Terminate -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either () (Client header point tip m ())
forall a b. a -> Either a b
Left ())
      , points :: [point] -> m (Either () (Client header point tip m ()))
points = \[point]
_ -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Client header point tip m ()
-> Either () (Client header point tip m ())
forall a b. b -> Either a b
Right Client header point tip m ()
go)
      }


-- | An instance of the client side of the chain sync protocol that
-- consumes into a 'Chain' stored in a 'StrictTVar'.
--
-- This is of course only useful in tests and reference implementations since
-- this is not a realistic chain representation.
--
chainSyncClientExample :: forall header block tip m a.
                          ( HasHeader header
                          , HasHeader block
                          , HeaderHash header ~ HeaderHash block
                          , MonadSTM m
                          )
                       => StrictTVar m (Chain header)
                       -> Client header (Point block) tip m a
                       -> ChainSyncClient header (Point block) tip m a
chainSyncClientExample :: forall header block tip (m :: * -> *) a.
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadSTM m) =>
StrictTVar m (Chain header)
-> Client header (Point block) tip m a
-> ChainSyncClient header (Point block) tip m a
chainSyncClientExample StrictTVar m (Chain header)
chainvar Client header (Point block) tip m a
client = m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle header (Point block) tip m a)
 -> ChainSyncClient header (Point block) tip m a)
-> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall a b. (a -> b) -> a -> b
$
    (a -> ClientStIdle header (Point block) tip m a)
-> (([Point block], Client header (Point block) tip m a)
    -> ClientStIdle header (Point block) tip m a)
-> Either a ([Point block], Client header (Point block) tip m a)
-> ClientStIdle header (Point block) tip m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> ClientStIdle header (Point block) tip m a
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone ([Point block], Client header (Point block) tip m a)
-> ClientStIdle header (Point block) tip m a
initialise (Either a ([Point block], Client header (Point block) tip m a)
 -> ClientStIdle header (Point block) tip m a)
-> m (Either
        a ([Point block], Client header (Point block) tip m a))
-> m (ClientStIdle header (Point block) tip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either a ([Point block], Client header (Point block) tip m a))
getChainPoints
  where
    initialise :: ([Point block], Client header (Point block) tip m a)
               -> ClientStIdle header (Point block) tip m a
    initialise :: ([Point block], Client header (Point block) tip m a)
-> ClientStIdle header (Point block) tip m a
initialise ([Point block]
points, Client header (Point block) tip m a
client') =
      [Point block]
-> ClientStIntersect header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect [Point block]
points (ClientStIntersect header (Point block) tip m a
 -> ClientStIdle header (Point block) tip m a)
-> ClientStIntersect header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
forall a b. (a -> b) -> a -> b
$
      -- In this consumer example, we do not care about whether the server
      -- found an intersection or not. If not, we'll just sync from genesis.
      --
      -- Alternative policies here include:
      --  iteratively finding the best intersection
      --  rejecting the server if there is no intersection in the last K blocks
      --
      ClientStIntersect {
        recvMsgIntersectFound :: Point block -> tip -> ChainSyncClient header (Point block) tip m a
recvMsgIntersectFound    = \Point block
_ tip
_ -> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle header (Point block) tip m a
-> m (ClientStIdle header (Point block) tip m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Client header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
requestNext Client header (Point block) tip m a
client')),
        recvMsgIntersectNotFound :: tip -> ChainSyncClient header (Point block) tip m a
recvMsgIntersectNotFound = \  tip
_ -> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle header (Point block) tip m a
-> m (ClientStIdle header (Point block) tip m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Client header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
requestNext Client header (Point block) tip m a
client'))
      }

    requestNext :: Client header (Point block) tip m a
                -> ClientStIdle header (Point block) tip m a
    requestNext :: Client header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
requestNext Client header (Point block) tip m a
client' =
      m ()
-> ClientStNext header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext header point tip m a
-> ClientStIdle header point tip m a
SendMsgRequestNext
        -- We have the opportunity to do something when receiving
        -- MsgAwaitReply. In this example we don't take up that opportunity.
        (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (Client header (Point block) tip m a
-> ClientStNext header (Point block) tip m a
handleNext Client header (Point block) tip m a
client')

    handleNext :: Client header (Point block) tip m a
               -> ClientStNext header (Point block) tip m a
    handleNext :: Client header (Point block) tip m a
-> ClientStNext header (Point block) tip m a
handleNext Client header (Point block) tip m a
client' =
      ClientStNext {
        recvMsgRollForward :: header -> tip -> ChainSyncClient header (Point block) tip m a
recvMsgRollForward  = \header
header tip
_tip -> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle header (Point block) tip m a)
 -> ChainSyncClient header (Point block) tip m a)
-> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall a b. (a -> b) -> a -> b
$ do
          header -> m ()
addBlock header
header
          choice <- Client header (Point block) tip m a
-> header -> m (Either a (Client header (Point block) tip m a))
forall header point tip (m :: * -> *) t.
Client header point tip m t
-> header -> m (Either t (Client header point tip m t))
rollforward Client header (Point block) tip m a
client' header
header
          pure $ case choice of
            Left a
a         -> a -> ClientStIdle header (Point block) tip m a
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone a
a
            Right Client header (Point block) tip m a
client'' -> Client header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
requestNext Client header (Point block) tip m a
client''

      , recvMsgRollBackward :: Point block -> tip -> ChainSyncClient header (Point block) tip m a
recvMsgRollBackward = \Point block
pIntersect tip
tip -> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle header (Point block) tip m a)
 -> ChainSyncClient header (Point block) tip m a)
-> m (ClientStIdle header (Point block) tip m a)
-> ChainSyncClient header (Point block) tip m a
forall a b. (a -> b) -> a -> b
$ do
          Point block -> m ()
rollback Point block
pIntersect
          choice <- Client header (Point block) tip m a
-> Point block
-> tip
-> m (Either a (Client header (Point block) tip m a))
forall header point tip (m :: * -> *) t.
Client header point tip m t
-> point -> tip -> m (Either t (Client header point tip m t))
rollbackward Client header (Point block) tip m a
client' Point block
pIntersect tip
tip
          pure $ case choice of
            Left a
a         -> a -> ClientStIdle header (Point block) tip m a
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone a
a
            Right Client header (Point block) tip m a
client'' -> Client header (Point block) tip m a
-> ClientStIdle header (Point block) tip m a
requestNext Client header (Point block) tip m a
client''
      }

    getChainPoints :: m (Either a ([Point block], Client header (Point block) tip m a))
    getChainPoints :: m (Either a ([Point block], Client header (Point block) tip m a))
getChainPoints = do
      pts <- [Int] -> Chain header -> [Point header]
forall block.
HasHeader block =>
[Int] -> Chain block -> [Point block]
Chain.selectPoints [Int]
recentOffsets (Chain header -> [Point header])
-> m (Chain header) -> m [Point header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Chain header) -> m (Chain header)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Chain header) -> STM m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain header)
chainvar)
      choice <- points client (fmap castPoint pts)
      pure $ case choice of
        Left a
a        -> a -> Either a ([Point block], Client header (Point block) tip m a)
forall a b. a -> Either a b
Left a
a
        Right Client header (Point block) tip m a
client' -> ([Point block], Client header (Point block) tip m a)
-> Either a ([Point block], Client header (Point block) tip m a)
forall a b. b -> Either a b
Right ((Point header -> Point block) -> [Point header] -> [Point block]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point header -> Point block
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint [Point header]
pts, Client header (Point block) tip m a
client')

    addBlock :: header -> m ()
    addBlock :: header -> m ()
addBlock header
b = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        chain <- StrictTVar m (Chain header) -> STM m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain header)
chainvar
        let !chain' = header -> Chain header -> Chain header
forall block.
HasHeader block =>
block -> Chain block -> Chain block
Chain.addBlock header
b Chain header
chain
        writeTVar chainvar chain'

    rollback :: Point block -> m ()
    rollback :: Point block -> m ()
rollback Point block
p = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        chain <- StrictTVar m (Chain header) -> STM m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain header)
chainvar
        --TODO: handle rollback failure
        let !chain' = case Point header -> Chain header -> Maybe (Chain header)
forall block.
HasHeader block =>
Point block -> Chain block -> Maybe (Chain block)
Chain.rollback (Point block -> Point header
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point block
p) Chain header
chain of
              Just Chain header
a  -> Chain header
a
              Maybe (Chain header)
Nothing -> [Char] -> Chain header
forall a. HasCallStack => [Char] -> a
error [Char]
"out of scope rollback"
        writeTVar chainvar chain'

-- | Offsets from the head of the chain to select points on the consumer's
-- chain to send to the producer. The specific choice here is fibonacci up
-- to 2160.
--
recentOffsets :: [Int]
recentOffsets :: [Int]
recentOffsets = [Int
0,Int
1,Int
2,Int
3,Int
5,Int
8,Int
13,Int
21,Int
34,Int
55,Int
89,Int
144,Int
233,Int
377,Int
610,Int
987,Int
1597,Int
2584]

-- | An instance of the server side of the chain sync protocol that reads from
-- a pure 'ChainProducerState' stored in a 'StrictTVar'.
--
-- This is of course only useful in tests and reference implementations since
-- this is not a realistic chain representation.
--
chainSyncServerExample :: forall blk header m a.
                          ( HasHeader blk
                          , MonadSTM m
                          , HeaderHash header ~ HeaderHash blk
                          )
                       => a
                       -> StrictTVar m (ChainProducerState blk)
                       -> (blk -> header)
                       -> ChainSyncServer header (Point blk) (Tip blk) m a
chainSyncServerExample :: forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
chainSyncServerExample a
recvMsgDoneClient StrictTVar m (ChainProducerState blk)
chainvar blk -> header
toHeader = m (ServerStIdle header (Point blk) (Tip blk) m a)
-> ChainSyncServer header (Point blk) (Tip blk) m a
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle header (Point blk) (Tip blk) m a)
 -> ChainSyncServer header (Point blk) (Tip blk) m a)
-> m (ServerStIdle header (Point blk) (Tip blk) m a)
-> ChainSyncServer header (Point blk) (Tip blk) m a
forall a b. (a -> b) -> a -> b
$
    Int -> ServerStIdle header (Point blk) (Tip blk) m a
idle (Int -> ServerStIdle header (Point blk) (Tip blk) m a)
-> m Int -> m (ServerStIdle header (Point blk) (Tip blk) m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Int
newFollower
  where
    idle :: FollowerId -> ServerStIdle header (Point blk) (Tip blk) m a
    idle :: Int -> ServerStIdle header (Point blk) (Tip blk) m a
idle Int
r =
      ServerStIdle {
        recvMsgRequestNext :: m (Either
     (ServerStNext header (Point blk) (Tip blk) m a)
     (m (ServerStNext header (Point blk) (Tip blk) m a)))
recvMsgRequestNext   = Int
-> m (Either
        (ServerStNext header (Point blk) (Tip blk) m a)
        (m (ServerStNext header (Point blk) (Tip blk) m a)))
handleRequestNext Int
r,
        recvMsgFindIntersect :: [Point blk]
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
recvMsgFindIntersect = \[Point blk]
pts -> Int
-> [Point blk]
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
handleFindIntersect Int
r ((Point blk -> Point blk) -> [Point blk] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
map Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint [Point blk]
pts),
        recvMsgDoneClient :: m a
recvMsgDoneClient    = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
recvMsgDoneClient
      }

    idle' :: FollowerId -> ChainSyncServer header (Point blk) (Tip blk) m a
    idle' :: Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' = m (ServerStIdle header (Point blk) (Tip blk) m a)
-> ChainSyncServer header (Point blk) (Tip blk) m a
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle header (Point blk) (Tip blk) m a)
 -> ChainSyncServer header (Point blk) (Tip blk) m a)
-> (Int -> m (ServerStIdle header (Point blk) (Tip blk) m a))
-> Int
-> ChainSyncServer header (Point blk) (Tip blk) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStIdle header (Point blk) (Tip blk) m a
-> m (ServerStIdle header (Point blk) (Tip blk) m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIdle header (Point blk) (Tip blk) m a
 -> m (ServerStIdle header (Point blk) (Tip blk) m a))
-> (Int -> ServerStIdle header (Point blk) (Tip blk) m a)
-> Int
-> m (ServerStIdle header (Point blk) (Tip blk) m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ServerStIdle header (Point blk) (Tip blk) m a
idle

    handleRequestNext :: FollowerId
                      -> m (Either (ServerStNext header (Point blk) (Tip blk) m a)
                                (m (ServerStNext header (Point blk) (Tip blk) m a)))
    handleRequestNext :: Int
-> m (Either
        (ServerStNext header (Point blk) (Tip blk) m a)
        (m (ServerStNext header (Point blk) (Tip blk) m a)))
handleRequestNext Int
r = do
      mupdate <- Int -> m (Maybe (Tip blk, ChainUpdate blk blk))
tryReadChainUpdate Int
r
      case mupdate of
        Just (Tip blk, ChainUpdate blk blk)
update -> Either
  (ServerStNext header (Point blk) (Tip blk) m a)
  (m (ServerStNext header (Point blk) (Tip blk) m a))
-> m (Either
        (ServerStNext header (Point blk) (Tip blk) m a)
        (m (ServerStNext header (Point blk) (Tip blk) m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStNext header (Point blk) (Tip blk) m a
-> Either
     (ServerStNext header (Point blk) (Tip blk) m a)
     (m (ServerStNext header (Point blk) (Tip blk) m a))
forall a b. a -> Either a b
Left  (Int
-> (Tip blk, ChainUpdate blk blk)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r (Tip blk, ChainUpdate blk blk)
update))
        Maybe (Tip blk, ChainUpdate blk blk)
Nothing     -> Either
  (ServerStNext header (Point blk) (Tip blk) m a)
  (m (ServerStNext header (Point blk) (Tip blk) m a))
-> m (Either
        (ServerStNext header (Point blk) (Tip blk) m a)
        (m (ServerStNext header (Point blk) (Tip blk) m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m (ServerStNext header (Point blk) (Tip blk) m a)
-> Either
     (ServerStNext header (Point blk) (Tip blk) m a)
     (m (ServerStNext header (Point blk) (Tip blk) m a))
forall a b. b -> Either a b
Right (Int
-> (Tip blk, ChainUpdate blk blk)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r ((Tip blk, ChainUpdate blk blk)
 -> ServerStNext header (Point blk) (Tip blk) m a)
-> m (Tip blk, ChainUpdate blk blk)
-> m (ServerStNext header (Point blk) (Tip blk) m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (Tip blk, ChainUpdate blk blk)
readChainUpdate Int
r))
                       -- Follower is at the head, have to block and wait for
                       -- the producer's state to change.

    sendNext :: FollowerId
             -> (Tip blk, ChainUpdate blk blk)
             -> ServerStNext header (Point blk) (Tip blk) m a
    sendNext :: Int
-> (Tip blk, ChainUpdate blk blk)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r (Tip blk
tip, AddBlock blk
b) = header
-> Tip blk
-> ChainSyncServer header (Point blk) (Tip blk) m a
-> ServerStNext header (Point blk) (Tip blk) m a
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward  (blk -> header
toHeader blk
b)  (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip Tip blk
tip) (Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' Int
r)
    sendNext Int
r (Tip blk
tip, RollBack Point blk
p) = Point blk
-> Tip blk
-> ChainSyncServer header (Point blk) (Tip blk) m a
-> ServerStNext header (Point blk) (Tip blk) m a
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollBackward (Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
p) (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip Tip blk
tip) (Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' Int
r)

    handleFindIntersect :: FollowerId
                        -> [Point blk]
                        -> m (ServerStIntersect header (Point blk) (Tip blk) m a)
    handleFindIntersect :: Int
-> [Point blk]
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
handleFindIntersect Int
r [Point blk]
points = do
      -- TODO: guard number of points
      -- Find the first point that is on our chain
      changed <- Int -> [Point blk] -> m (Maybe (Point blk), Tip blk)
improveReadPoint Int
r [Point blk]
points
      case changed of
        (Just Point blk
pt, Tip blk
tip) -> ServerStIntersect header (Point blk) (Tip blk) m a
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStIntersect header (Point blk) (Tip blk) m a
 -> m (ServerStIntersect header (Point blk) (Tip blk) m a))
-> ServerStIntersect header (Point blk) (Tip blk) m a
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
forall a b. (a -> b) -> a -> b
$ Point blk
-> Tip blk
-> ChainSyncServer header (Point blk) (Tip blk) m a
-> ServerStIntersect header (Point blk) (Tip blk) m a
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound    (Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
pt) (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip Tip blk
tip) (Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' Int
r)
        (Maybe (Point blk)
Nothing, Tip blk
tip) -> ServerStIntersect header (Point blk) (Tip blk) m a
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStIntersect header (Point blk) (Tip blk) m a
 -> m (ServerStIntersect header (Point blk) (Tip blk) m a))
-> ServerStIntersect header (Point blk) (Tip blk) m a
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
forall a b. (a -> b) -> a -> b
$ Tip blk
-> ChainSyncServer header (Point blk) (Tip blk) m a
-> ServerStIntersect header (Point blk) (Tip blk) m a
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip Tip blk
tip)  (Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' Int
r)

    newFollower :: m FollowerId
    newFollower :: m Int
newFollower = STM m Int -> m Int
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Int -> m Int) -> STM m Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
      cps <- StrictTVar m (ChainProducerState blk)
-> STM m (ChainProducerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState blk)
chainvar
      let (cps', rid) = ChainProducerState.initFollower genesisPoint cps
      writeTVar chainvar cps'
      return rid

    improveReadPoint :: FollowerId
                     -> [Point blk]
                     -> m (Maybe (Point blk), Tip blk)
    improveReadPoint :: Int -> [Point blk] -> m (Maybe (Point blk), Tip blk)
improveReadPoint Int
rid [Point blk]
points =
      STM m (Maybe (Point blk), Tip blk)
-> m (Maybe (Point blk), Tip blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (Point blk), Tip blk)
 -> m (Maybe (Point blk), Tip blk))
-> STM m (Maybe (Point blk), Tip blk)
-> m (Maybe (Point blk), Tip blk)
forall a b. (a -> b) -> a -> b
$ do
        cps <- StrictTVar m (ChainProducerState blk)
-> STM m (ChainProducerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState blk)
chainvar
        case ChainProducerState.findFirstPoint (map castPoint points) cps of
          Maybe (Point blk)
Nothing     -> let chain :: Chain blk
chain = ChainProducerState blk -> Chain blk
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState blk
cps
                         in (Maybe (Point blk), Tip blk) -> STM m (Maybe (Point blk), Tip blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk)
forall a. Maybe a
Nothing, Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Chain blk -> Tip blk
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain blk
chain))
          Just Point blk
ipoint -> do
            let !cps' :: ChainProducerState blk
cps' = Int
-> Point blk -> ChainProducerState blk -> ChainProducerState blk
forall block.
HasHeader block =>
Int
-> Point block
-> ChainProducerState block
-> ChainProducerState block
ChainProducerState.updateFollower Int
rid Point blk
ipoint ChainProducerState blk
cps
            StrictTVar m (ChainProducerState blk)
-> ChainProducerState blk -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState blk)
chainvar ChainProducerState blk
cps'
            let chain :: Chain blk
chain = ChainProducerState blk -> Chain blk
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState blk
cps'
            (Maybe (Point blk), Tip blk) -> STM m (Maybe (Point blk), Tip blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just (Point blk -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point blk
ipoint), Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Chain blk -> Tip blk
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain blk
chain))

    tryReadChainUpdate :: FollowerId
                       -> m (Maybe (Tip blk, ChainUpdate blk blk))
    tryReadChainUpdate :: Int -> m (Maybe (Tip blk, ChainUpdate blk blk))
tryReadChainUpdate Int
rid =
      STM m (Maybe (Tip blk, ChainUpdate blk blk))
-> m (Maybe (Tip blk, ChainUpdate blk blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (Tip blk, ChainUpdate blk blk))
 -> m (Maybe (Tip blk, ChainUpdate blk blk)))
-> STM m (Maybe (Tip blk, ChainUpdate blk blk))
-> m (Maybe (Tip blk, ChainUpdate blk blk))
forall a b. (a -> b) -> a -> b
$ do
        cps <- StrictTVar m (ChainProducerState blk)
-> STM m (ChainProducerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState blk)
chainvar
        case ChainProducerState.followerInstruction rid cps of
          Maybe (ChainUpdate blk blk, ChainProducerState blk)
Nothing -> Maybe (Tip blk, ChainUpdate blk blk)
-> STM m (Maybe (Tip blk, ChainUpdate blk blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tip blk, ChainUpdate blk blk)
forall a. Maybe a
Nothing
          Just (ChainUpdate blk blk
u, ChainProducerState blk
cps') -> do
            StrictTVar m (ChainProducerState blk)
-> ChainProducerState blk -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState blk)
chainvar ChainProducerState blk
cps'
            let chain :: Chain blk
chain = ChainProducerState blk -> Chain blk
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState blk
cps'
            Maybe (Tip blk, ChainUpdate blk blk)
-> STM m (Maybe (Tip blk, ChainUpdate blk blk))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Tip blk, ChainUpdate blk blk)
 -> STM m (Maybe (Tip blk, ChainUpdate blk blk)))
-> Maybe (Tip blk, ChainUpdate blk blk)
-> STM m (Maybe (Tip blk, ChainUpdate blk blk))
forall a b. (a -> b) -> a -> b
$ (Tip blk, ChainUpdate blk blk)
-> Maybe (Tip blk, ChainUpdate blk blk)
forall a. a -> Maybe a
Just (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Chain blk -> Tip blk
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain blk
chain), ChainUpdate blk blk
u)

    readChainUpdate :: FollowerId -> m (Tip blk, ChainUpdate blk blk)
    readChainUpdate :: Int -> m (Tip blk, ChainUpdate blk blk)
readChainUpdate Int
rid =
      STM m (Tip blk, ChainUpdate blk blk)
-> m (Tip blk, ChainUpdate blk blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Tip blk, ChainUpdate blk blk)
 -> m (Tip blk, ChainUpdate blk blk))
-> STM m (Tip blk, ChainUpdate blk blk)
-> m (Tip blk, ChainUpdate blk blk)
forall a b. (a -> b) -> a -> b
$ do
        cps <- StrictTVar m (ChainProducerState blk)
-> STM m (ChainProducerState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState blk)
chainvar
        case ChainProducerState.followerInstruction rid cps of
          Maybe (ChainUpdate blk blk, ChainProducerState blk)
Nothing        -> STM m (Tip blk, ChainUpdate blk blk)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          Just (ChainUpdate blk blk
u, ChainProducerState blk
cps') -> do
            StrictTVar m (ChainProducerState blk)
-> ChainProducerState blk -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState blk)
chainvar ChainProducerState blk
cps'
            let chain :: Chain blk
chain = ChainProducerState blk -> Chain blk
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState blk
cps'
            (Tip blk, ChainUpdate blk blk)
-> STM m (Tip blk, ChainUpdate blk blk)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tip blk -> Tip blk
forall {k1} {k2} (a :: k1) (b :: k2).
(HeaderHash a ~ HeaderHash b) =>
Tip a -> Tip b
castTip (Chain blk -> Tip blk
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain blk
chain), ChainUpdate blk blk
u)