{-# 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))
}
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)
}
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
$
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
(() -> 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
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'
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]
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))
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
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)