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

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

import           Control.Monad.Class.MonadSTM.Strict

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

data Client header point tip m t = Client
  { 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))
  , 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))
  , Client header point tip m t
-> [point] -> m (Client header point tip m t)
points       :: [point] -> m (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 :: Client header point tip m void
pureClient = Client :: forall header point tip (m :: * -> *) t.
(point -> tip -> m (Either t (Client header point tip m t)))
-> (header -> m (Either t (Client header point tip m t)))
-> ([point] -> m (Client header point tip m t))
-> Client header point tip m t
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 (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 (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 (Client header point tip m void)
points       = \[point]
_ -> Client header point tip m void
-> m (Client header point tip m void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: 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 :: forall header point tip (m :: * -> *) t.
(point -> tip -> m (Either t (Client header point tip m t)))
-> (header -> m (Either t (Client header point tip m t)))
-> ([point] -> m (Client header point tip m t))
-> Client header point tip m t
Client
      { rollbackward :: point -> tip -> m (Either () (Client header point tip m ()))
rollbackward = \point
_ tip
_ -> do
          ControlMessage
ctrl <- ControlMessageSTM m -> m ControlMessage
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ControlMessageSTM m
controlMessageSTM
          case ControlMessage
ctrl of
            ControlMessage
Continue  -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
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 (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
          ControlMessage
ctrl <- ControlMessageSTM m -> m ControlMessage
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ControlMessageSTM m
controlMessageSTM
          case ControlMessage
ctrl of
            ControlMessage
Continue  -> Either () (Client header point tip m ())
-> m (Either () (Client header point tip m ()))
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 (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 (Client header point tip m ())
points = \[point]
_ -> Client header point tip m () -> m (Client header point tip m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 tip m a.
                          (HasHeader header, MonadSTM m)
                       => StrictTVar m (Chain header)
                       -> Client header (Point header) tip m a
                       -> ChainSyncClient header (Point header) tip m a
chainSyncClientExample :: StrictTVar m (Chain header)
-> Client header (Point header) tip m a
-> ChainSyncClient header (Point header) tip m a
chainSyncClientExample StrictTVar m (Chain header)
chainvar Client header (Point header) tip m a
client = m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) 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 header) tip m a)
 -> ChainSyncClient header (Point header) tip m a)
-> m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) tip m a
forall a b. (a -> b) -> a -> b
$
    ([Point header], Client header (Point header) tip m a)
-> ClientStIdle header (Point header) tip m a
initialise (([Point header], Client header (Point header) tip m a)
 -> ClientStIdle header (Point header) tip m a)
-> m ([Point header], Client header (Point header) tip m a)
-> m (ClientStIdle header (Point header) tip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ([Point header], Client header (Point header) tip m a)
getChainPoints
  where
    initialise :: ([Point header], Client header (Point header) tip m a)
               -> ClientStIdle header (Point header) tip m a
    initialise :: ([Point header], Client header (Point header) tip m a)
-> ClientStIdle header (Point header) tip m a
initialise ([Point header]
points, Client header (Point header) tip m a
client') =
      [Point header]
-> ClientStIntersect header (Point header) tip m a
-> ClientStIdle header (Point header) tip m a
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect [Point header]
points (ClientStIntersect header (Point header) tip m a
 -> ClientStIdle header (Point header) tip m a)
-> ClientStIntersect header (Point header) tip m a
-> ClientStIdle header (Point header) 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 :: forall header point tip (m :: * -> *) a.
(point -> tip -> ChainSyncClient header point tip m a)
-> (tip -> ChainSyncClient header point tip m a)
-> ClientStIntersect header point tip m a
ClientStIntersect {
        recvMsgIntersectFound :: Point header
-> tip -> ChainSyncClient header (Point header) tip m a
recvMsgIntersectFound    = \Point header
_ tip
_ -> m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) 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 header) tip m a
-> m (ClientStIdle header (Point header) tip m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Client header (Point header) tip m a
-> ClientStIdle header (Point header) tip m a
requestNext Client header (Point header) tip m a
client')),
        recvMsgIntersectNotFound :: tip -> ChainSyncClient header (Point header) tip m a
recvMsgIntersectNotFound = \  tip
_ -> m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) 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 header) tip m a
-> m (ClientStIdle header (Point header) tip m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Client header (Point header) tip m a
-> ClientStIdle header (Point header) tip m a
requestNext Client header (Point header) tip m a
client'))
      }

    requestNext :: Client header (Point header) tip m a
                -> ClientStIdle header (Point header) tip m a
    requestNext :: Client header (Point header) tip m a
-> ClientStIdle header (Point header) tip m a
requestNext Client header (Point header) tip m a
client' =
      ClientStNext header (Point header) tip m a
-> m (ClientStNext header (Point header) tip m a)
-> ClientStIdle header (Point header) tip m a
forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> m (ClientStNext header point tip m a)
-> ClientStIdle header point tip m a
SendMsgRequestNext
        (Client header (Point header) tip m a
-> ClientStNext header (Point header) tip m a
handleNext Client header (Point header) tip m a
client')
        -- We received a wait message, and we have the opportunity to do
        -- something. In this example we don't take up that opportunity.
        (ClientStNext header (Point header) tip m a
-> m (ClientStNext header (Point header) tip m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Client header (Point header) tip m a
-> ClientStNext header (Point header) tip m a
handleNext Client header (Point header) tip m a
client'))

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

      , recvMsgRollBackward :: Point header
-> tip -> ChainSyncClient header (Point header) tip m a
recvMsgRollBackward = \Point header
pIntersect tip
tip -> m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) 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 header) tip m a)
 -> ChainSyncClient header (Point header) tip m a)
-> m (ClientStIdle header (Point header) tip m a)
-> ChainSyncClient header (Point header) tip m a
forall a b. (a -> b) -> a -> b
$ do
          Point header -> m ()
rollback Point header
pIntersect
          Either a (Client header (Point header) tip m a)
choice <- Client header (Point header) tip m a
-> Point header
-> tip
-> m (Either a (Client header (Point header) 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 header) tip m a
client' Point header
pIntersect tip
tip
          ClientStIdle header (Point header) tip m a
-> m (ClientStIdle header (Point header) tip m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle header (Point header) tip m a
 -> m (ClientStIdle header (Point header) tip m a))
-> ClientStIdle header (Point header) tip m a
-> m (ClientStIdle header (Point header) tip m a)
forall a b. (a -> b) -> a -> b
$ case Either a (Client header (Point header) tip m a)
choice of
            Left a
a         -> a -> ClientStIdle header (Point header) tip m a
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
SendMsgDone a
a
            Right Client header (Point header) tip m a
client'' -> Client header (Point header) tip m a
-> ClientStIdle header (Point header) tip m a
requestNext Client header (Point header) tip m a
client''
      }

    getChainPoints :: m ([Point header], Client header (Point header) tip m a)
    getChainPoints :: m ([Point header], Client header (Point header) tip m a)
getChainPoints = do
      [Point header]
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 (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)
      Client header (Point header) tip m a
client' <- Client header (Point header) tip m a
-> [Point header] -> m (Client header (Point header) tip m a)
forall header point tip (m :: * -> *) t.
Client header point tip m t
-> [point] -> m (Client header point tip m t)
points Client header (Point header) tip m a
client [Point header]
pts
      ([Point header], Client header (Point header) tip m a)
-> m ([Point header], Client header (Point header) tip m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Point header]
pts, Client header (Point header) tip m a
client')

    addBlock :: header -> m ()
    addBlock :: header -> m ()
addBlock header
b = STM m () -> m ()
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 header
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' :: Chain header
chain' = header -> Chain header -> Chain header
forall block.
HasHeader block =>
block -> Chain block -> Chain block
Chain.addBlock header
b Chain header
chain
        StrictTVar m (Chain header) -> Chain header -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Chain header)
chainvar Chain header
chain'

    rollback :: Point header -> m ()
    rollback :: Point header -> m ()
rollback Point header
p = STM m () -> m ()
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 header
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' :: Chain header
chain' = case Point header -> Chain header -> Maybe (Chain header)
forall block.
HasHeader block =>
Point block -> Chain block -> Maybe (Chain block)
Chain.rollback Point header
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"
        StrictTVar m (Chain header) -> Chain header -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Chain header)
chainvar Chain header
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 header
                          , MonadSTM m
                          , HeaderHash header ~ HeaderHash blk
                          )
                       => a
                       -> StrictTVar m (ChainProducerState header)
                       -> ChainSyncServer header (Point blk) (Tip blk) m a
chainSyncServerExample :: a
-> StrictTVar m (ChainProducerState header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
chainSyncServerExample a
recvMsgDoneClient StrictTVar m (ChainProducerState header)
chainvar = 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 :: forall header point tip (m :: * -> *) a.
m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
-> ([point] -> m (ServerStIntersect header point tip m a))
-> m a
-> ServerStIdle header point tip m a
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 = Int
-> [Point blk]
-> m (ServerStIntersect header (Point blk) (Tip blk) m a)
handleFindIntersect Int
r,
        recvMsgDoneClient :: m a
recvMsgDoneClient    = 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 (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
      Maybe (Tip blk, ChainUpdate header header)
mupdate <- Int -> m (Maybe (Tip blk, ChainUpdate header header))
tryReadChainUpdate Int
r
      case Maybe (Tip blk, ChainUpdate header header)
mupdate of
        Just (Tip blk, ChainUpdate header header)
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 (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 header header)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r (Tip blk, ChainUpdate header header)
update))
        Maybe (Tip blk, ChainUpdate header header)
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 (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 header header)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r ((Tip blk, ChainUpdate header header)
 -> ServerStNext header (Point blk) (Tip blk) m a)
-> m (Tip blk, ChainUpdate header header)
-> 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 header header)
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 header header)
             -> ServerStNext header (Point blk) (Tip blk) m a
    sendNext :: Int
-> (Tip blk, ChainUpdate header header)
-> ServerStNext header (Point blk) (Tip blk) m a
sendNext Int
r (Tip blk
tip, AddBlock header
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  header
b             Tip blk
tip (Int -> ChainSyncServer header (Point blk) (Tip blk) m a
idle' Int
r)
    sendNext Int
r (Tip blk
tip, RollBack Point header
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 header -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point header
p) 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
      (Maybe (Point blk), Tip blk)
changed <- Int -> [Point blk] -> m (Maybe (Point blk), Tip blk)
improveReadPoint Int
r [Point blk]
points
      case (Maybe (Point blk), Tip blk)
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 (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
pt 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 (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 (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 (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
      ChainProducerState header
cps <- StrictTVar m (ChainProducerState header)
-> STM m (ChainProducerState header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState header)
chainvar
      let (ChainProducerState header
cps', Int
rid) = Point header
-> ChainProducerState header -> (ChainProducerState header, Int)
forall block.
HasHeader block =>
Point block
-> ChainProducerState block -> (ChainProducerState block, Int)
ChainProducerState.initFollower Point header
forall block. Point block
genesisPoint ChainProducerState header
cps
      StrictTVar m (ChainProducerState header)
-> ChainProducerState header -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState header)
chainvar ChainProducerState header
cps'
      Int -> STM m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
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 (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
        ChainProducerState header
cps <- StrictTVar m (ChainProducerState header)
-> STM m (ChainProducerState header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState header)
chainvar
        case [Point header] -> ChainProducerState header -> Maybe (Point header)
forall block.
HasHeader block =>
[Point block] -> ChainProducerState block -> Maybe (Point block)
ChainProducerState.findFirstPoint ((Point blk -> Point header) -> [Point blk] -> [Point header]
forall a b. (a -> b) -> [a] -> [b]
map Point blk -> Point header
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint [Point blk]
points) ChainProducerState header
cps of
          Maybe (Point header)
Nothing     -> let chain :: Chain header
chain = ChainProducerState header -> Chain header
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState header
cps
                         in (Maybe (Point blk), Tip blk) -> STM m (Maybe (Point blk), Tip blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Point blk)
forall a. Maybe a
Nothing, Tip header -> Tip blk
forall a b. (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
castTip (Chain header -> Tip header
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain header
chain))
          Just Point header
ipoint -> do
            let !cps' :: ChainProducerState header
cps' = Int
-> Point header
-> ChainProducerState header
-> ChainProducerState header
forall block.
HasHeader block =>
Int
-> Point block
-> ChainProducerState block
-> ChainProducerState block
ChainProducerState.updateFollower Int
rid Point header
ipoint ChainProducerState header
cps
            StrictTVar m (ChainProducerState header)
-> ChainProducerState header -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState header)
chainvar ChainProducerState header
cps'
            let chain :: Chain header
chain = ChainProducerState header -> Chain header
forall block. ChainProducerState block -> Chain block
ChainProducerState.chainState ChainProducerState header
cps'
            (Maybe (Point blk), Tip blk) -> STM m (Maybe (Point blk), Tip blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just (Point header -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point header
ipoint), Tip header -> Tip blk
forall a b. (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
castTip (Chain header -> Tip header
forall block. HasHeader block => Chain block -> Tip block
Chain.headTip Chain header
chain))

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

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