{-# LANGUAGE NamedFieldPuns #-}

module Ouroboros.Network.Protocol.ChainSync.Direct where

import Ouroboros.Network.Protocol.ChainSync.Client as Client
import Ouroboros.Network.Protocol.ChainSync.Server as Server

-- | The 'ClientStream m' and 'ServerStream m' types are complementary. The
-- former can be used to feed the latter directly, in the same thread.
-- That's demonstrated here by constructing 'direct'.
--
direct :: Monad m
       => ChainSyncServer header point tip m a
       -> ChainSyncClient header point tip m b
       -> m (a, b)
direct :: forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct (ChainSyncServer m (ServerStIdle header point tip m a)
mserver) (ChainSyncClient m (ClientStIdle header point tip m b)
mclient) = do
  server <- m (ServerStIdle header point tip m a)
mserver
  client <- mclient
  direct_ server client

direct_ :: Monad m
        => ServerStIdle header point tip m a
        -> ClientStIdle header point tip m b
        -> m (a, b)
direct_ :: forall (m :: * -> *) header point tip a b.
Monad m =>
ServerStIdle header point tip m a
-> ClientStIdle header point tip m b -> m (a, b)
direct_  ServerStIdle{m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a
-> m (Either
        (ServerStNext header point tip m a)
        (m (ServerStNext header point tip m a)))
recvMsgRequestNext}
        (Client.SendMsgRequestNext m ()
stAwait ClientStNext header point tip m b
stNext) = do
    mresp <- m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext
    case mresp of
      Left  ServerStNext header point tip m a
resp    -> ServerStNext header point tip m a
-> ClientStNext header point tip m b -> m (a, b)
forall {m :: * -> *} {header} {point} {tip} {a} {b}.
Monad m =>
ServerStNext header point tip m a
-> ClientStNext header point tip m b -> m (a, b)
directStNext ServerStNext header point tip m a
resp ClientStNext header point tip m b
stNext
      Right m (ServerStNext header point tip m a)
waiting -> do resp <- m (ServerStNext header point tip m a)
waiting
                          stAwait
                          directStNext resp stNext
  where
    directStNext :: ServerStNext header point tip m a
-> ClientStNext header point tip m b -> m (a, b)
directStNext (SendMsgRollForward header
header tip
tip ChainSyncServer header point tip m a
server')
                  ClientStNext{header -> tip -> ChainSyncClient header point tip m b
recvMsgRollForward :: header -> tip -> ChainSyncClient header point tip m b
recvMsgRollForward :: forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> header -> tip -> ChainSyncClient header point tip m a
recvMsgRollForward} = do
      ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct ChainSyncServer header point tip m a
server' (header -> tip -> ChainSyncClient header point tip m b
recvMsgRollForward header
header tip
tip)

    directStNext (SendMsgRollBackward point
pIntersect tip
tip ChainSyncServer header point tip m a
server')
                  ClientStNext{point -> tip -> ChainSyncClient header point tip m b
recvMsgRollBackward :: point -> tip -> ChainSyncClient header point tip m b
recvMsgRollBackward :: forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> point -> tip -> ChainSyncClient header point tip m a
recvMsgRollBackward} = do
      ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct ChainSyncServer header point tip m a
server' (point -> tip -> ChainSyncClient header point tip m b
recvMsgRollBackward point
pIntersect tip
tip)

direct_  ServerStIdle{[point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect :: [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a
-> [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect}
        (Client.SendMsgFindIntersect [point]
points
          ClientStIntersect{point -> tip -> ChainSyncClient header point tip m b
recvMsgIntersectFound :: point -> tip -> ChainSyncClient header point tip m b
recvMsgIntersectFound :: forall header point tip (m :: * -> *) a.
ClientStIntersect header point tip m a
-> point -> tip -> ChainSyncClient header point tip m a
recvMsgIntersectFound,
                            tip -> ChainSyncClient header point tip m b
recvMsgIntersectNotFound :: tip -> ChainSyncClient header point tip m b
recvMsgIntersectNotFound :: forall header point tip (m :: * -> *) a.
ClientStIntersect header point tip m a
-> tip -> ChainSyncClient header point tip m a
recvMsgIntersectNotFound}) = do
    sIntersect <- [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect [point]
points
    case sIntersect of
      SendMsgIntersectFound  point
pIntersect tip
tip ChainSyncServer header point tip m a
server' ->
        ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct ChainSyncServer header point tip m a
server' (point -> tip -> ChainSyncClient header point tip m b
recvMsgIntersectFound point
pIntersect tip
tip)

      SendMsgIntersectNotFound          tip
tip ChainSyncServer header point tip m a
server' ->
        ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct ChainSyncServer header point tip m a
server' (tip -> ChainSyncClient header point tip m b
recvMsgIntersectNotFound         tip
tip)

direct_ ServerStIdle{m a
recvMsgDoneClient :: m a
recvMsgDoneClient :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a -> m a
recvMsgDoneClient}
       (Client.SendMsgDone b
clientDone) = do
    msgDoneClient <- m a
recvMsgDoneClient
    return (msgDoneClient, clientDone)