{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
module Convex.NodeClient.Progress(progressClient) where

import           Cardano.Api                                           (Block (..),
                                                                        BlockHeader (..),
                                                                        BlockInMode (..),
                                                                        BlockNo (..),
                                                                        ChainPoint (..),
                                                                        ChainTip (..))
import qualified Cardano.Api                                           as CAPI
import           Cardano.Slotting.Slot                                 (WithOrigin (At))
import           Control.Monad                                         (when)
import           Convex.NodeClient.Types                               (ClientBlock,
                                                                        PipelinedLedgerStateClient (..),
                                                                        fromChainTip)
import qualified Data.Text                                             as Text
import           Data.Time                                             (diffUTCTime,
                                                                        getCurrentTime)
import           Network.TypedProtocol.Pipelined                       (Nat (..))
import           Ouroboros.Consensus.Block.Abstract                    (WithOrigin (..))
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined  (ClientPipelinedStIdle (..),
                                                                        ClientStNext (..))
import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined  as CSP
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision (PipelineDecision (..),
                                                                        pipelineDecisionMax)

{-| A 'PipelinedLedgerStateClient' that simply shows the progress of synchronising with the node.
-}
progressClient :: PipelinedLedgerStateClient
progressClient :: PipelinedLedgerStateClient
progressClient = ChainSyncClientPipelined
  (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> PipelinedLedgerStateClient
PipelinedLedgerStateClient forall a b. (a -> b) -> a -> b
$ forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
CSP.ChainSyncClientPipelined forall a b. (a -> b) -> a -> b
$ do
  UTCTime
startTime <- IO UTCTime
getCurrentTime
  let
    pipelineSize :: Word32
pipelineSize = Word32
50 -- TODO: Configurable

    clientIdle_RequestMoreN
      :: WithOrigin BlockNo
      -> WithOrigin BlockNo
      -> Nat n -- Number of requests inflight.
      -> CSP.ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ()
    clientIdle_RequestMoreN :: forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip Nat n
n
      = case forall (n :: N).
Word32
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word32
pipelineSize Nat n
n WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip  of
          PipelineDecision n
Collect -> case Nat n
n of
            Succ Nat n
predN -> forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse forall a. Maybe a
Nothing (forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
predN)
          PipelineDecision n
_ -> forall (n :: N) header point tip (m :: * -> *) a.
ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip (forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n))

    clientNextN :: Nat n -> ClientStNext n ClientBlock ChainPoint ChainTip IO ()
    clientNextN :: forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
n =
      ClientStNext {
          recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollForward = \(BlockInMode block :: Block era
block@(Block (BlockHeader SlotNo
_ Hash BlockHeader
_ currBlockNo :: BlockNo
currBlockNo@(BlockNo Word64
blockNo)) [Tx era]
_) EraInMode era CardanoMode
_) ChainTip
serverChainTip -> do
            let newClientTip :: WithOrigin BlockNo
newClientTip = forall t. t -> WithOrigin t
At BlockNo
currBlockNo
                newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
blockNo forall a. Integral a => a -> a -> a
`mod` Word64
10_000 forall a. Eq a => a -> a -> Bool
== Word64
0) forall a b. (a -> b) -> a -> b
$ do
              forall era. Block era -> IO ()
printBlock Block era
block
              ChainTip -> IO ()
printTip ChainTip
serverChainTip
              UTCTime
now <- IO UTCTime
getCurrentTime
              let elapsedTime :: Double
elapsedTime = forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
startTime) :: Double
                  rate :: Double
rate = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
blockNo forall a. Fractional a => a -> a -> a
/ Double
elapsedTime
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Rate = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
rate forall a. [a] -> [a] -> [a]
++ String
" blocks/second"
            if WithOrigin BlockNo
newClientTip forall a. Eq a => a -> a -> Bool
== WithOrigin BlockNo
newServerTip
              then  forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
              else forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n)
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollBackward = \ChainPoint
k ChainTip
serverChainTip -> do
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Rollback to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ChainPoint
k
            let newClientTip :: WithOrigin BlockNo
newClientTip = case ChainPoint
k of
                  ChainPoint SlotNo
_slotNo Hash BlockHeader
_bhHash -> forall t. WithOrigin t
Origin
                  ChainPoint
ChainPointAtGenesis        -> forall t. WithOrigin t
Origin
                newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n)
        }

    clientIdle_DoneN :: Nat n -> IO (ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ())
    clientIdle_DoneN :: forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n = case Nat n
n of
      Succ Nat n
predN -> do
        String -> IO ()
putStrLn String
"Chain Sync: done! (Ignoring remaining responses)"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse forall a. Maybe a
Nothing (forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
predN) -- Ignore remaining message responses
      Nat n
Zero -> do
        String -> IO ()
putStrLn String
"Chain Sync: done!"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone ()

    clientNext_DoneN :: Nat n -> ClientStNext n ClientBlock ChainPoint ChainTip IO ()
    clientNext_DoneN :: forall (n :: N).
Nat n
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
n =
      ClientStNext {
          recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollForward = \BlockInMode CardanoMode
_ ChainTip
_ -> forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> forall (n :: N).
Nat n
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n
        }

    printBlock :: Block era -> IO ()
    printBlock :: forall era. Block era -> IO ()
printBlock (Block (BlockHeader SlotNo
_ Hash BlockHeader
_ BlockNo
currBlockNo) [Tx era]
transactions)
      = String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show BlockNo
currBlockNo forall a. [a] -> [a] -> [a]
++ String
" transactions: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
transactions)

    printTip :: ChainTip -> IO ()
    printTip :: ChainTip -> IO ()
printTip = \case
      ChainTip
ChainTipAtGenesis -> String -> IO ()
putStrLn String
"server tip at genesis"
      ChainTip SlotNo
slot Hash BlockHeader
hash BlockNo
block -> do
        let txt :: Text
txt = forall a. SerialiseAsRawBytes a => a -> Text
CAPI.serialiseToRawBytesHexText Hash BlockHeader
hash
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"server tip: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SlotNo
slot forall a. Semigroup a => a -> a -> a
<> String
"; " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
txt forall a. Semigroup a => a -> a -> a
<> String
"; " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show BlockNo
block

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN forall t. WithOrigin t
Origin forall t. WithOrigin t
Origin forall (n :: N). ('Z ~ n) => Nat n
Zero)