{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-| This module exports data types for logging, events and configuration
-}
module Cardano.Node.Socket.Emulator.Types where

import Cardano.Api (NetworkId, Value)
import Cardano.Chain.Slotting (EpochSlots (..))
import Cardano.Ledger.Block qualified as CL
import Cardano.Ledger.Era qualified as CL
import Cardano.Ledger.Shelley.API (extractTx, unsafeMakeValidated)
import Cardano.Node.Emulator.API (EmulatorLogs, EmulatorMsg, EmulatorState, emptyEmulatorStateWithInitialDist,
                                  esChainState)
import Cardano.Node.Emulator.Internal.Node.Chain qualified as EC
import Cardano.Node.Emulator.Internal.Node.Params (testnet)
import Cardano.Node.Emulator.Internal.Node.TimeSlot (SlotConfig)
import Codec.Serialise (DeserialiseFailure)
import Codec.Serialise qualified as CBOR
import Control.Concurrent (MVar, modifyMVar_, readMVar)
import Control.Concurrent.STM
import Control.Lens (makeLenses, view, (&), (.~), (^.))
import Control.Monad (forever)
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadTimer (MonadDelay (threadDelay), MonadTimer)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Hash (SHA256, hash)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Extras qualified as JSON
import Data.ByteArray qualified as BA
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Short qualified as BS
import Data.Coerce (coerce)
import Data.Default (Default, def)
import Data.Foldable (toList)
import Data.Functor (void, (<&>))
import Data.Map qualified as Map
import Data.Maybe (listToMaybe)
import Data.Sequence.Strict (fromList)
import Data.Text qualified as Text
import Data.Time.Clock (UTCTime)
import Data.Time.Format.ISO8601 qualified as F
import Data.Time.Units (Millisecond)
import Data.Time.Units.Extra ()
import Data.Void (Void)
import GHC.Generics (Generic)
import Ledger (Block, CardanoTx, OnChainTx (..))
import Ledger.Address (CardanoAddress)
import Ledger.CardanoWallet
import Ledger.Test (testNetworkMagic)
import Network.TypedProtocol.Codec (Codec)
import Ouroboros.Consensus.Byron.Ledger qualified as Byron
import Ouroboros.Consensus.Cardano.Block (CardanoBlock, CodecConfig (..))
import Ouroboros.Consensus.Cardano.Block qualified as OC
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraHash (..))
import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
import Ouroboros.Consensus.Network.NodeToClient (ClientCodecs, cChainSyncCodec, cTxSubmissionCodec, clientCodecs)
import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion, supportedNodeToClientVersions)
import Ouroboros.Consensus.Protocol.Praos.Header qualified as Praos
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
import Ouroboros.Consensus.Shelley.Ledger qualified as Shelley
import Ouroboros.Network.Block (Point)
import Ouroboros.Network.Block qualified as Ouroboros
import Ouroboros.Network.Mux
import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), NodeToClientVersionData (..))
import Ouroboros.Network.Protocol.ChainSync.Type qualified as ChainSync
import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as TxSubmission
import Ouroboros.Network.Util.ShowProxy
import Prettyprinter (Pretty, pretty, viaShow, vsep, (<+>))
import Prettyprinter.Extras (PrettyShow (PrettyShow))
import Servant.Client (BaseUrl (BaseUrl, baseUrlPort), Scheme (Http))

type Tip = Ouroboros.Tip (CardanoBlock StandardCrypto)

type TxPool = [CardanoTx]

data SocketEmulatorState = SocketEmulatorState
  { SocketEmulatorState -> EmulatorState
_emulatorState :: EmulatorState
  , SocketEmulatorState -> TChan Block
_channel       :: TChan Block
  , SocketEmulatorState -> Tip
_tip           :: Tip
  } deriving ((forall x. SocketEmulatorState -> Rep SocketEmulatorState x)
-> (forall x. Rep SocketEmulatorState x -> SocketEmulatorState)
-> Generic SocketEmulatorState
forall x. Rep SocketEmulatorState x -> SocketEmulatorState
forall x. SocketEmulatorState -> Rep SocketEmulatorState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SocketEmulatorState x -> SocketEmulatorState
$cfrom :: forall x. SocketEmulatorState -> Rep SocketEmulatorState x
Generic)

makeLenses ''SocketEmulatorState

instance Show SocketEmulatorState where
    -- Skip showing the full chain
    show :: SocketEmulatorState -> String
show SocketEmulatorState {EmulatorState
_emulatorState :: EmulatorState
_emulatorState :: SocketEmulatorState -> EmulatorState
_emulatorState, Tip
_tip :: Tip
_tip :: SocketEmulatorState -> Tip
_tip} =
        String
"SocketEmulatorState { " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EmulatorState -> String
forall a. Show a => a -> String
show EmulatorState
_emulatorState
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Tip -> String
forall a. Show a => a -> String
show Tip
_tip String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" }"

-- | Node server configuration
data NodeServerConfig =
    NodeServerConfig
        { NodeServerConfig -> BaseUrl
nscBaseUrl                    :: BaseUrl
        -- ^ base url of the service
        , NodeServerConfig -> [WalletNumber]
nscInitialTxWallets           :: [WalletNumber]
        -- ^ The wallets that receive money from the initial transaction.
        , NodeServerConfig -> String
nscSocketPath                 :: FilePath
        -- ^ Path to the socket used to communicate with the server.
        , NodeServerConfig -> Integer
nscKeptBlocks                 :: Integer
        -- ^ The number of blocks to keep for replaying to newly connected clients
        , NodeServerConfig -> SlotConfig
nscSlotConfig                 :: SlotConfig
        -- ^ Beginning of slot 0.
        , NodeServerConfig -> NetworkId
nscNetworkId                  :: NetworkId
        -- ^ NetworkId that's used with the CardanoAPI.
        , NodeServerConfig -> Maybe String
nscProtocolParametersJsonPath :: Maybe FilePath
        -- ^ Path to a JSON file containing the protocol parameters
        }
    deriving stock (Int -> NodeServerConfig -> ShowS
[NodeServerConfig] -> ShowS
NodeServerConfig -> String
(Int -> NodeServerConfig -> ShowS)
-> (NodeServerConfig -> String)
-> ([NodeServerConfig] -> ShowS)
-> Show NodeServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeServerConfig] -> ShowS
$cshowList :: [NodeServerConfig] -> ShowS
show :: NodeServerConfig -> String
$cshow :: NodeServerConfig -> String
showsPrec :: Int -> NodeServerConfig -> ShowS
$cshowsPrec :: Int -> NodeServerConfig -> ShowS
Show, NodeServerConfig -> NodeServerConfig -> Bool
(NodeServerConfig -> NodeServerConfig -> Bool)
-> (NodeServerConfig -> NodeServerConfig -> Bool)
-> Eq NodeServerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeServerConfig -> NodeServerConfig -> Bool
$c/= :: NodeServerConfig -> NodeServerConfig -> Bool
== :: NodeServerConfig -> NodeServerConfig -> Bool
$c== :: NodeServerConfig -> NodeServerConfig -> Bool
Eq, (forall x. NodeServerConfig -> Rep NodeServerConfig x)
-> (forall x. Rep NodeServerConfig x -> NodeServerConfig)
-> Generic NodeServerConfig
forall x. Rep NodeServerConfig x -> NodeServerConfig
forall x. NodeServerConfig -> Rep NodeServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeServerConfig x -> NodeServerConfig
$cfrom :: forall x. NodeServerConfig -> Rep NodeServerConfig x
Generic)
    deriving anyclass (Value -> Parser [NodeServerConfig]
Value -> Parser NodeServerConfig
(Value -> Parser NodeServerConfig)
-> (Value -> Parser [NodeServerConfig])
-> FromJSON NodeServerConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NodeServerConfig]
$cparseJSONList :: Value -> Parser [NodeServerConfig]
parseJSON :: Value -> Parser NodeServerConfig
$cparseJSON :: Value -> Parser NodeServerConfig
FromJSON, [NodeServerConfig] -> Value
[NodeServerConfig] -> Encoding
NodeServerConfig -> Value
NodeServerConfig -> Encoding
(NodeServerConfig -> Value)
-> (NodeServerConfig -> Encoding)
-> ([NodeServerConfig] -> Value)
-> ([NodeServerConfig] -> Encoding)
-> ToJSON NodeServerConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NodeServerConfig] -> Encoding
$ctoEncodingList :: [NodeServerConfig] -> Encoding
toJSONList :: [NodeServerConfig] -> Value
$ctoJSONList :: [NodeServerConfig] -> Value
toEncoding :: NodeServerConfig -> Encoding
$ctoEncoding :: NodeServerConfig -> Encoding
toJSON :: NodeServerConfig -> Value
$ctoJSON :: NodeServerConfig -> Value
ToJSON)

defaultNodeServerConfig :: NodeServerConfig
defaultNodeServerConfig :: NodeServerConfig
defaultNodeServerConfig =
    NodeServerConfig :: BaseUrl
-> [WalletNumber]
-> String
-> Integer
-> SlotConfig
-> NetworkId
-> Maybe String
-> NodeServerConfig
NodeServerConfig
      -- See Note [pab-ports] in 'test/full/Plutus/PAB/CliSpec.hs'.
      { nscBaseUrl :: BaseUrl
nscBaseUrl = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" Int
9082 String
""
      , nscInitialTxWallets :: [WalletNumber]
nscInitialTxWallets =
          [ Integer -> WalletNumber
WalletNumber Integer
1
          , Integer -> WalletNumber
WalletNumber Integer
2
          , Integer -> WalletNumber
WalletNumber Integer
3
          , Integer -> WalletNumber
WalletNumber Integer
4
          , Integer -> WalletNumber
WalletNumber Integer
5
          , Integer -> WalletNumber
WalletNumber Integer
6
          , Integer -> WalletNumber
WalletNumber Integer
7
          , Integer -> WalletNumber
WalletNumber Integer
8
          , Integer -> WalletNumber
WalletNumber Integer
9
          , Integer -> WalletNumber
WalletNumber Integer
10
          ]
      , nscSocketPath :: String
nscSocketPath = String
"/tmp/node-server.sock"
      , nscKeptBlocks :: Integer
nscKeptBlocks = Integer
100
      , nscSlotConfig :: SlotConfig
nscSlotConfig = SlotConfig
forall a. Default a => a
def
      , nscNetworkId :: NetworkId
nscNetworkId = NetworkId
testnet
      , nscProtocolParametersJsonPath :: Maybe String
nscProtocolParametersJsonPath = Maybe String
forall a. Maybe a
Nothing
      }

instance Default NodeServerConfig where
  def :: NodeServerConfig
def = NodeServerConfig
defaultNodeServerConfig

instance Pretty NodeServerConfig where
  pretty :: NodeServerConfig -> Doc ann
pretty NodeServerConfig{ BaseUrl
nscBaseUrl :: BaseUrl
nscBaseUrl :: NodeServerConfig -> BaseUrl
nscBaseUrl, String
nscSocketPath :: String
nscSocketPath :: NodeServerConfig -> String
nscSocketPath, NetworkId
nscNetworkId :: NetworkId
nscNetworkId :: NodeServerConfig -> NetworkId
nscNetworkId, Integer
nscKeptBlocks :: Integer
nscKeptBlocks :: NodeServerConfig -> Integer
nscKeptBlocks } =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ann
"Socket:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
nscSocketPath
         , Doc ann
"Network Id:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NetworkId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NetworkId
nscNetworkId
         , Doc ann
"Port:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (BaseUrl -> Int
baseUrlPort BaseUrl
nscBaseUrl)
         , Doc ann
"Security Param:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
nscKeptBlocks
         ]

-- | Application State
data AppState =
    AppState
        { AppState -> SocketEmulatorState
_socketEmulatorState :: SocketEmulatorState -- ^ blockchain state
        , AppState -> EmulatorLogs
_emulatorLogs        :: EmulatorLogs -- ^ history of all log messages
        }
    deriving (Int -> AppState -> ShowS
[AppState] -> ShowS
AppState -> String
(Int -> AppState -> ShowS)
-> (AppState -> String) -> ([AppState] -> ShowS) -> Show AppState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppState] -> ShowS
$cshowList :: [AppState] -> ShowS
show :: AppState -> String
$cshow :: AppState -> String
showsPrec :: Int -> AppState -> ShowS
$cshowsPrec :: Int -> AppState -> ShowS
Show)

makeLenses 'AppState

fromEmulatorChainState :: MonadIO m => EmulatorState -> m SocketEmulatorState
fromEmulatorChainState :: EmulatorState -> m SocketEmulatorState
fromEmulatorChainState EmulatorState
state = do
    TChan Block
ch <- IO (TChan Block) -> m (TChan Block)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan Block) -> m (TChan Block))
-> IO (TChan Block) -> m (TChan Block)
forall a b. (a -> b) -> a -> b
$ STM (TChan Block) -> IO (TChan Block)
forall a. STM a -> IO a
atomically STM (TChan Block)
forall a. STM (TChan a)
newTChan
    let chainNewestFirst :: [Block]
chainNewestFirst = Getting [Block] EmulatorState [Block] -> EmulatorState -> [Block]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ChainState -> Const [Block] ChainState)
-> EmulatorState -> Const [Block] EmulatorState
Lens' EmulatorState ChainState
esChainState ((ChainState -> Const [Block] ChainState)
 -> EmulatorState -> Const [Block] EmulatorState)
-> (([Block] -> Const [Block] [Block])
    -> ChainState -> Const [Block] ChainState)
-> Getting [Block] EmulatorState [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Block] -> Const [Block] [Block])
-> ChainState -> Const [Block] ChainState
Lens' ChainState [Block]
EC.chainNewestFirst) EmulatorState
state
    let currentSlot :: Slot
currentSlot = Getting Slot EmulatorState Slot -> EmulatorState -> Slot
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ChainState -> Const Slot ChainState)
-> EmulatorState -> Const Slot EmulatorState
Lens' EmulatorState ChainState
esChainState ((ChainState -> Const Slot ChainState)
 -> EmulatorState -> Const Slot EmulatorState)
-> ((Slot -> Const Slot Slot)
    -> ChainState -> Const Slot ChainState)
-> Getting Slot EmulatorState Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot -> Const Slot Slot) -> ChainState -> Const Slot ChainState
Lens' ChainState Slot
EC.chainCurrentSlot) EmulatorState
state
    m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        (Block -> IO ()) -> [Block] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Block -> STM ()) -> Block -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan Block -> Block -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Block
ch) [Block]
chainNewestFirst
    SocketEmulatorState -> m SocketEmulatorState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SocketEmulatorState -> m SocketEmulatorState)
-> SocketEmulatorState -> m SocketEmulatorState
forall a b. (a -> b) -> a -> b
$ SocketEmulatorState :: EmulatorState -> TChan Block -> Tip -> SocketEmulatorState
SocketEmulatorState
        { _channel :: TChan Block
_channel       = TChan Block
ch
        , _emulatorState :: EmulatorState
_emulatorState = EmulatorState
state
        , _tip :: Tip
_tip           = case [Block] -> Maybe Block
forall a. [a] -> Maybe a
listToMaybe [Block]
chainNewestFirst of
                              Maybe Block
Nothing -> Tip
forall b. Tip b
Ouroboros.TipGenesis
                              Just Block
block -> SlotNo
-> HeaderHash (CardanoBlock StandardCrypto) -> BlockNo -> Tip
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Ouroboros.Tip (Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
currentSlot) (BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
coerce (BlockId
 -> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
-> BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$ Block -> BlockId
blockId Block
block) (Slot -> BlockNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
currentSlot)
        }

-- | 'ChainState' with initial values
initialChainState :: MonadIO m => Map.Map CardanoAddress Value -> m SocketEmulatorState
initialChainState :: Map CardanoAddress Value -> m SocketEmulatorState
initialChainState = EmulatorState -> m SocketEmulatorState
forall (m :: * -> *).
MonadIO m =>
EmulatorState -> m SocketEmulatorState
fromEmulatorChainState (EmulatorState -> m SocketEmulatorState)
-> (Map CardanoAddress Value -> EmulatorState)
-> Map CardanoAddress Value
-> m SocketEmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CardanoAddress Value -> EmulatorState
emptyEmulatorStateWithInitialDist

getChannel :: MonadIO m => MVar AppState -> m (TChan Block)
getChannel :: MVar AppState -> m (TChan Block)
getChannel MVar AppState
mv = IO AppState -> m AppState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar AppState -> IO AppState
forall a. MVar a -> IO a
readMVar MVar AppState
mv) m AppState -> (AppState -> TChan Block) -> m (TChan Block)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting (TChan Block) AppState (TChan Block)
-> AppState -> TChan Block
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SocketEmulatorState -> Const (TChan Block) SocketEmulatorState)
-> AppState -> Const (TChan Block) AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Const (TChan Block) SocketEmulatorState)
 -> AppState -> Const (TChan Block) AppState)
-> ((TChan Block -> Const (TChan Block) (TChan Block))
    -> SocketEmulatorState -> Const (TChan Block) SocketEmulatorState)
-> Getting (TChan Block) AppState (TChan Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TChan Block -> Const (TChan Block) (TChan Block))
-> SocketEmulatorState -> Const (TChan Block) SocketEmulatorState
Lens' SocketEmulatorState (TChan Block)
channel)

-- Get the current tip.
getTip :: MonadIO m => MVar AppState -> m Tip
getTip :: MVar AppState -> m Tip
getTip MVar AppState
mv = IO AppState -> m AppState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar AppState -> IO AppState
forall a. MVar a -> IO a
readMVar MVar AppState
mv) m AppState -> (AppState -> Tip) -> m Tip
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Getting Tip AppState Tip -> AppState -> Tip
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SocketEmulatorState -> Const Tip SocketEmulatorState)
-> AppState -> Const Tip AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Const Tip SocketEmulatorState)
 -> AppState -> Const Tip AppState)
-> ((Tip -> Const Tip Tip)
    -> SocketEmulatorState -> Const Tip SocketEmulatorState)
-> Getting Tip AppState Tip
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tip -> Const Tip Tip)
-> SocketEmulatorState -> Const Tip SocketEmulatorState
Lens' SocketEmulatorState Tip
tip)

-- Set the new tip
setTip :: MonadIO m => MVar AppState -> Block -> m ()
setTip :: MVar AppState -> Block -> m ()
setTip MVar AppState
mv Block
block = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
mv ((AppState -> IO AppState) -> IO ())
-> (AppState -> IO AppState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
oldState -> do
  let slot :: Slot
slot = AppState
oldState AppState -> Getting Slot AppState Slot -> Slot
forall s a. s -> Getting a s a -> a
^. (SocketEmulatorState -> Const Slot SocketEmulatorState)
-> AppState -> Const Slot AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Const Slot SocketEmulatorState)
 -> AppState -> Const Slot AppState)
-> ((Slot -> Const Slot Slot)
    -> SocketEmulatorState -> Const Slot SocketEmulatorState)
-> Getting Slot AppState Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmulatorState -> Const Slot EmulatorState)
-> SocketEmulatorState -> Const Slot SocketEmulatorState
Lens' SocketEmulatorState EmulatorState
emulatorState ((EmulatorState -> Const Slot EmulatorState)
 -> SocketEmulatorState -> Const Slot SocketEmulatorState)
-> Getting Slot EmulatorState Slot
-> (Slot -> Const Slot Slot)
-> SocketEmulatorState
-> Const Slot SocketEmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainState -> Const Slot ChainState)
-> EmulatorState -> Const Slot EmulatorState
Lens' EmulatorState ChainState
esChainState ((ChainState -> Const Slot ChainState)
 -> EmulatorState -> Const Slot EmulatorState)
-> ((Slot -> Const Slot Slot)
    -> ChainState -> Const Slot ChainState)
-> Getting Slot EmulatorState Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slot -> Const Slot Slot) -> ChainState -> Const Slot ChainState
Lens' ChainState Slot
EC.chainCurrentSlot
  AppState -> IO AppState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppState -> IO AppState) -> AppState -> IO AppState
forall a b. (a -> b) -> a -> b
$ AppState
oldState AppState -> (AppState -> AppState) -> AppState
forall a b. a -> (a -> b) -> b
& (SocketEmulatorState -> Identity SocketEmulatorState)
-> AppState -> Identity AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Identity SocketEmulatorState)
 -> AppState -> Identity AppState)
-> ((Tip -> Identity Tip)
    -> SocketEmulatorState -> Identity SocketEmulatorState)
-> (Tip -> Identity Tip)
-> AppState
-> Identity AppState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tip -> Identity Tip)
-> SocketEmulatorState -> Identity SocketEmulatorState
Lens' SocketEmulatorState Tip
tip ((Tip -> Identity Tip) -> AppState -> Identity AppState)
-> Tip -> AppState -> AppState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
-> HeaderHash (CardanoBlock StandardCrypto) -> BlockNo -> Tip
forall b. SlotNo -> HeaderHash b -> BlockNo -> Tip b
Ouroboros.Tip (Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
slot) (BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
coerce (BlockId
 -> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
-> BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$ Block -> BlockId
blockId Block
block) (Slot -> BlockNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
slot)

-- Logging ------------------------------------------------------------------------------------------------------------

-- | Top-level logging data type for structural logging
-- inside the CNSE server.
data CNSEServerLogMsg =
    StartingSlotCoordination UTCTime Millisecond
    | StartingCNSEServer Int
    | ProcessingEmulatorMsg EmulatorMsg
    deriving ((forall x. CNSEServerLogMsg -> Rep CNSEServerLogMsg x)
-> (forall x. Rep CNSEServerLogMsg x -> CNSEServerLogMsg)
-> Generic CNSEServerLogMsg
forall x. Rep CNSEServerLogMsg x -> CNSEServerLogMsg
forall x. CNSEServerLogMsg -> Rep CNSEServerLogMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CNSEServerLogMsg x -> CNSEServerLogMsg
$cfrom :: forall x. CNSEServerLogMsg -> Rep CNSEServerLogMsg x
Generic, Int -> CNSEServerLogMsg -> ShowS
[CNSEServerLogMsg] -> ShowS
CNSEServerLogMsg -> String
(Int -> CNSEServerLogMsg -> ShowS)
-> (CNSEServerLogMsg -> String)
-> ([CNSEServerLogMsg] -> ShowS)
-> Show CNSEServerLogMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CNSEServerLogMsg] -> ShowS
$cshowList :: [CNSEServerLogMsg] -> ShowS
show :: CNSEServerLogMsg -> String
$cshow :: CNSEServerLogMsg -> String
showsPrec :: Int -> CNSEServerLogMsg -> ShowS
$cshowsPrec :: Int -> CNSEServerLogMsg -> ShowS
Show, [CNSEServerLogMsg] -> Value
[CNSEServerLogMsg] -> Encoding
CNSEServerLogMsg -> Value
CNSEServerLogMsg -> Encoding
(CNSEServerLogMsg -> Value)
-> (CNSEServerLogMsg -> Encoding)
-> ([CNSEServerLogMsg] -> Value)
-> ([CNSEServerLogMsg] -> Encoding)
-> ToJSON CNSEServerLogMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CNSEServerLogMsg] -> Encoding
$ctoEncodingList :: [CNSEServerLogMsg] -> Encoding
toJSONList :: [CNSEServerLogMsg] -> Value
$ctoJSONList :: [CNSEServerLogMsg] -> Value
toEncoding :: CNSEServerLogMsg -> Encoding
$ctoEncoding :: CNSEServerLogMsg -> Encoding
toJSON :: CNSEServerLogMsg -> Value
$ctoJSON :: CNSEServerLogMsg -> Value
ToJSON, Value -> Parser [CNSEServerLogMsg]
Value -> Parser CNSEServerLogMsg
(Value -> Parser CNSEServerLogMsg)
-> (Value -> Parser [CNSEServerLogMsg])
-> FromJSON CNSEServerLogMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CNSEServerLogMsg]
$cparseJSONList :: Value -> Parser [CNSEServerLogMsg]
parseJSON :: Value -> Parser CNSEServerLogMsg
$cparseJSON :: Value -> Parser CNSEServerLogMsg
FromJSON)

instance Pretty CNSEServerLogMsg where
    pretty :: CNSEServerLogMsg -> Doc ann
pretty = \case
        StartingSlotCoordination UTCTime
initialSlotTime Millisecond
slotLength  ->
            Doc ann
"Starting slot coordination thread."
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Initial slot time:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UTCTime -> String
forall t. ISO8601 t => t -> String
F.iso8601Show UTCTime
initialSlotTime)
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Slot length:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Millisecond -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Millisecond
slotLength
        StartingCNSEServer Int
p   -> Doc ann
"Starting Cardano Node Emulator on port" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
p
        ProcessingEmulatorMsg EmulatorMsg
e -> Doc ann
"Processing emulator event:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> EmulatorMsg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty EmulatorMsg
e

-- | The node protocols require a block header type.
newtype BlockId = BlockId { BlockId -> ShortByteString
getBlockId :: BS.ShortByteString }
  deriving (BlockId -> BlockId -> Bool
(BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool) -> Eq BlockId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockId -> BlockId -> Bool
$c/= :: BlockId -> BlockId -> Bool
== :: BlockId -> BlockId -> Bool
$c== :: BlockId -> BlockId -> Bool
Eq, Eq BlockId
Eq BlockId
-> (BlockId -> BlockId -> Ordering)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> Bool)
-> (BlockId -> BlockId -> BlockId)
-> (BlockId -> BlockId -> BlockId)
-> Ord BlockId
BlockId -> BlockId -> Bool
BlockId -> BlockId -> Ordering
BlockId -> BlockId -> BlockId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockId -> BlockId -> BlockId
$cmin :: BlockId -> BlockId -> BlockId
max :: BlockId -> BlockId -> BlockId
$cmax :: BlockId -> BlockId -> BlockId
>= :: BlockId -> BlockId -> Bool
$c>= :: BlockId -> BlockId -> Bool
> :: BlockId -> BlockId -> Bool
$c> :: BlockId -> BlockId -> Bool
<= :: BlockId -> BlockId -> Bool
$c<= :: BlockId -> BlockId -> Bool
< :: BlockId -> BlockId -> Bool
$c< :: BlockId -> BlockId -> Bool
compare :: BlockId -> BlockId -> Ordering
$ccompare :: BlockId -> BlockId -> Ordering
$cp1Ord :: Eq BlockId
Ord, (forall x. BlockId -> Rep BlockId x)
-> (forall x. Rep BlockId x -> BlockId) -> Generic BlockId
forall x. Rep BlockId x -> BlockId
forall x. BlockId -> Rep BlockId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockId x -> BlockId
$cfrom :: forall x. BlockId -> Rep BlockId x
Generic)
  deriving newtype (Decoder s BlockId
Decoder s [BlockId]
[BlockId] -> Encoding
BlockId -> Encoding
(BlockId -> Encoding)
-> (forall s. Decoder s BlockId)
-> ([BlockId] -> Encoding)
-> (forall s. Decoder s [BlockId])
-> Serialise BlockId
forall s. Decoder s [BlockId]
forall s. Decoder s BlockId
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [BlockId]
$cdecodeList :: forall s. Decoder s [BlockId]
encodeList :: [BlockId] -> Encoding
$cencodeList :: [BlockId] -> Encoding
decode :: Decoder s BlockId
$cdecode :: forall s. Decoder s BlockId
encode :: BlockId -> Encoding
$cencode :: BlockId -> Encoding
CBOR.Serialise)
  deriving [BlockId] -> Doc ann
BlockId -> Doc ann
(forall ann. BlockId -> Doc ann)
-> (forall ann. [BlockId] -> Doc ann) -> Pretty BlockId
forall ann. [BlockId] -> Doc ann
forall ann. BlockId -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [BlockId] -> Doc ann
$cprettyList :: forall ann. [BlockId] -> Doc ann
pretty :: BlockId -> Doc ann
$cpretty :: forall ann. BlockId -> Doc ann
Pretty via (PrettyShow BlockId)

instance Show BlockId where
    show :: BlockId -> String
show = Text -> String
Text.unpack (Text -> String) -> (BlockId -> Text) -> BlockId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
JSON.encodeByteString (ByteString -> Text) -> (BlockId -> ByteString) -> BlockId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
BS.fromShort (ShortByteString -> ByteString)
-> (BlockId -> ShortByteString) -> BlockId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> ShortByteString
getBlockId

-- | A hash of the block's contents.
blockId :: Block -> BlockId
blockId :: Block -> BlockId
blockId = ShortByteString -> BlockId
BlockId
        (ShortByteString -> BlockId)
-> (Block -> ShortByteString) -> Block -> BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
BS.toShort
        (ByteString -> ShortByteString)
-> (Block -> ByteString) -> Block -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
        (Digest SHA256 -> ByteString)
-> (Block -> Digest SHA256) -> Block -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteArrayAccess ByteString, HashAlgorithm SHA256) =>
ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash @_ @SHA256
        (ByteString -> Digest SHA256)
-> (Block -> ByteString) -> Block -> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict
        (ByteString -> ByteString)
-> (Block -> ByteString) -> Block -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> ByteString
forall a. Serialise a => a -> ByteString
CBOR.serialise

-- | Protocol versions
nodeToClientVersion :: NodeToClientVersion
nodeToClientVersion :: NodeToClientVersion
nodeToClientVersion = NodeToClientVersion
NodeToClientV_13

-- | A temporary definition of the protocol version. This will be moved as an
-- argument to the client connection function in a future PR (the network magic
-- number matches the one in the test net created by scripts)
nodeToClientVersionData :: NodeToClientVersionData
nodeToClientVersionData :: NodeToClientVersionData
nodeToClientVersionData = NodeToClientVersionData :: NetworkMagic -> NodeToClientVersionData
NodeToClientVersionData { networkMagic :: NetworkMagic
networkMagic = NetworkMagic
testNetworkMagic }

-- | A protocol client that will never leave the initial state.
doNothingInitiatorProtocol
  :: MonadTimer m => RunMiniProtocol 'InitiatorMode BSL.ByteString m a Void
doNothingInitiatorProtocol :: RunMiniProtocol 'InitiatorMode ByteString m a Void
doNothingInitiatorProtocol =
    MuxPeer ByteString m a
-> RunMiniProtocol 'InitiatorMode ByteString m a Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString m a
 -> RunMiniProtocol 'InitiatorMode ByteString m a Void)
-> MuxPeer ByteString m a
-> RunMiniProtocol 'InitiatorMode ByteString m a Void
forall a b. (a -> b) -> a -> b
$ (Channel m ByteString -> m (a, Maybe ByteString))
-> MuxPeer ByteString m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw ((Channel m ByteString -> m (a, Maybe ByteString))
 -> MuxPeer ByteString m a)
-> (Channel m ByteString -> m (a, Maybe ByteString))
-> MuxPeer ByteString m a
forall a b. (a -> b) -> a -> b
$
    m (a, Maybe ByteString)
-> Channel m ByteString -> m (a, Maybe ByteString)
forall a b. a -> b -> a
const (m (a, Maybe ByteString)
 -> Channel m ByteString -> m (a, Maybe ByteString))
-> m (a, Maybe ByteString)
-> Channel m ByteString
-> m (a, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ m () -> m (a, Maybe ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (a, Maybe ByteString))
-> m () -> m (a, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1e6

doNothingResponderProtocol
  :: MonadTimer m => RunMiniProtocol 'ResponderMode BSL.ByteString m Void a
doNothingResponderProtocol :: RunMiniProtocol 'ResponderMode ByteString m Void a
doNothingResponderProtocol =
  MuxPeer ByteString m a
-> RunMiniProtocol 'ResponderMode ByteString m Void a
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly (MuxPeer ByteString m a
 -> RunMiniProtocol 'ResponderMode ByteString m Void a)
-> MuxPeer ByteString m a
-> RunMiniProtocol 'ResponderMode ByteString m Void a
forall a b. (a -> b) -> a -> b
$ (Channel m ByteString -> m (a, Maybe ByteString))
-> MuxPeer ByteString m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw ((Channel m ByteString -> m (a, Maybe ByteString))
 -> MuxPeer ByteString m a)
-> (Channel m ByteString -> m (a, Maybe ByteString))
-> MuxPeer ByteString m a
forall a b. (a -> b) -> a -> b
$
  m (a, Maybe ByteString)
-> Channel m ByteString -> m (a, Maybe ByteString)
forall a b. a -> b -> a
const (m (a, Maybe ByteString)
 -> Channel m ByteString -> m (a, Maybe ByteString))
-> m (a, Maybe ByteString)
-> Channel m ByteString
-> m (a, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ m () -> m (a, Maybe ByteString)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (a, Maybe ByteString))
-> m () -> m (a, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1e6

-- | Boilerplate codecs used for protocol serialisation.

-- | The number of epochSlots is specific to each blockchain instance. This value
-- is what the cardano main and testnet uses. Only applies to the Byron era.
epochSlots :: EpochSlots
epochSlots :: EpochSlots
epochSlots = Word64 -> EpochSlots
EpochSlots Word64
21600

codecVersion :: BlockNodeToClientVersion (CardanoBlock StandardCrypto)
codecVersion :: BlockNodeToClientVersion (CardanoBlock StandardCrypto)
codecVersion = Map
  NodeToClientVersion
  (HardForkNodeToClientVersion
     (ByronBlock : CardanoShelleyEras StandardCrypto))
versionMap Map
  NodeToClientVersion
  (HardForkNodeToClientVersion
     (ByronBlock : CardanoShelleyEras StandardCrypto))
-> NodeToClientVersion
-> HardForkNodeToClientVersion
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall k a. Ord k => Map k a -> k -> a
Map.! NodeToClientVersion
nodeToClientVersion
  where
    versionMap :: Map
  NodeToClientVersion
  (BlockNodeToClientVersion (CardanoBlock StandardCrypto))
versionMap =
      Proxy (CardanoBlock StandardCrypto)
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (CardanoBlock StandardCrypto))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions
        (Proxy (CardanoBlock StandardCrypto)
forall k (t :: k). Proxy t
Proxy @(CardanoBlock StandardCrypto))

codecConfig :: CodecConfig (CardanoBlock StandardCrypto)
codecConfig :: CodecConfig (CardanoBlock StandardCrypto)
codecConfig =
  CodecConfig ByronBlock
-> CodecConfig
     (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
-> CodecConfig
     (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
-> CodecConfig
     (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
-> CodecConfig
     (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
-> CodecConfig
     (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
-> CodecConfig (CardanoBlock StandardCrypto)
forall c.
CodecConfig ByronBlock
-> CodecConfig (ShelleyBlock (TPraos c) (ShelleyEra c))
-> CodecConfig (ShelleyBlock (TPraos c) (AllegraEra c))
-> CodecConfig (ShelleyBlock (TPraos c) (MaryEra c))
-> CodecConfig (ShelleyBlock (TPraos c) (AlonzoEra c))
-> CodecConfig (ShelleyBlock (Praos c) (BabbageEra c))
-> CardanoCodecConfig c
CardanoCodecConfig
    (EpochSlots -> CodecConfig ByronBlock
Byron.ByronCodecConfig EpochSlots
epochSlots)
    CodecConfig
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
forall proto era. CodecConfig (ShelleyBlock proto era)
Shelley.ShelleyCodecConfig
    CodecConfig
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
forall proto era. CodecConfig (ShelleyBlock proto era)
Shelley.ShelleyCodecConfig
    CodecConfig
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
forall proto era. CodecConfig (ShelleyBlock proto era)
Shelley.ShelleyCodecConfig
    CodecConfig
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
forall proto era. CodecConfig (ShelleyBlock proto era)
Shelley.ShelleyCodecConfig
    CodecConfig
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
forall proto era. CodecConfig (ShelleyBlock proto era)
Shelley.ShelleyCodecConfig

nodeToClientCodecs
  :: forall m. MonadST m
  => ClientCodecs (CardanoBlock StandardCrypto) m
nodeToClientCodecs :: ClientCodecs (CardanoBlock StandardCrypto) m
nodeToClientCodecs =
  CodecConfig (CardanoBlock StandardCrypto)
-> BlockNodeToClientVersion (CardanoBlock StandardCrypto)
-> NodeToClientVersion
-> ClientCodecs (CardanoBlock StandardCrypto) m
forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 ShowQuery (BlockQuery blk), StandardHash blk,
 Serialise (HeaderHash blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> ClientCodecs blk m
clientCodecs CodecConfig (CardanoBlock StandardCrypto)
codecConfig BlockNodeToClientVersion (CardanoBlock StandardCrypto)
codecVersion NodeToClientVersion
nodeToClientVersion

-- | These codecs are currently used in the mock nodes and will
--   probably soon get removed as the mock nodes are phased out.
chainSyncCodec
  :: (block ~ CardanoBlock StandardCrypto)
  => Codec (ChainSync.ChainSync block (Point block) Tip)
           DeserialiseFailure
           IO BSL.ByteString
chainSyncCodec :: Codec
  (ChainSync block (Point block) Tip)
  DeserialiseFailure
  IO
  ByteString
chainSyncCodec = Codecs'
  (CardanoBlock StandardCrypto)
  (CardanoBlock StandardCrypto)
  DeserialiseFailure
  IO
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (ChainSync
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip)
     DeserialiseFailure
     IO
     ByteString
forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
cChainSyncCodec Codecs'
  (CardanoBlock StandardCrypto)
  (CardanoBlock StandardCrypto)
  DeserialiseFailure
  IO
  ByteString
  ByteString
  ByteString
  ByteString
forall (m :: * -> *).
MonadST m =>
ClientCodecs (CardanoBlock StandardCrypto) m
nodeToClientCodecs

txSubmissionCodec
  :: (block ~ CardanoBlock StandardCrypto)
  => Codec (TxSubmission.LocalTxSubmission (Shelley.GenTx block) (ApplyTxErr block))
           DeserialiseFailure IO BSL.ByteString
txSubmissionCodec :: Codec
  (LocalTxSubmission (GenTx block) (ApplyTxErr block))
  DeserialiseFailure
  IO
  ByteString
txSubmissionCodec = Codecs'
  (CardanoBlock StandardCrypto)
  (CardanoBlock StandardCrypto)
  DeserialiseFailure
  IO
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (LocalTxSubmission
        (GenTx (CardanoBlock StandardCrypto))
        (ApplyTxErr (CardanoBlock StandardCrypto)))
     DeserialiseFailure
     IO
     ByteString
forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cTxSubmissionCodec Codecs'
  (CardanoBlock StandardCrypto)
  (CardanoBlock StandardCrypto)
  DeserialiseFailure
  IO
  ByteString
  ByteString
  ByteString
  ByteString
forall (m :: * -> *).
MonadST m =>
ClientCodecs (CardanoBlock StandardCrypto) m
nodeToClientCodecs

toCardanoBlock :: Praos.Header StandardCrypto -> Block -> CardanoBlock StandardCrypto
toCardanoBlock :: Header StandardCrypto -> Block -> CardanoBlock StandardCrypto
toCardanoBlock Header StandardCrypto
header Block
block = ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto)
-> CardanoBlock StandardCrypto
forall c. ShelleyBlock (Praos c) (BabbageEra c) -> CardanoBlock c
OC.BlockBabbage (Block
  (ShelleyProtocolHeader (Praos StandardCrypto))
  (BabbageEra StandardCrypto)
-> ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto)
forall proto era.
ShelleyCompatible proto era =>
Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
Shelley.mkShelleyBlock (Block
   (ShelleyProtocolHeader (Praos StandardCrypto))
   (BabbageEra StandardCrypto)
 -> ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
-> Block
     (ShelleyProtocolHeader (Praos StandardCrypto))
     (BabbageEra StandardCrypto)
-> ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto)
forall a b. (a -> b) -> a -> b
$ Header StandardCrypto
-> TxSeq (BabbageEra StandardCrypto)
-> Block (Header StandardCrypto) (BabbageEra StandardCrypto)
forall era h.
(Era era, ToCBORGroup (TxSeq era), ToCBOR h) =>
h -> TxSeq era -> Block h era
CL.Block Header StandardCrypto
header (TxSeq (BabbageEra StandardCrypto)
 -> Block (Header StandardCrypto) (BabbageEra StandardCrypto))
-> TxSeq (BabbageEra StandardCrypto)
-> Block (Header StandardCrypto) (BabbageEra StandardCrypto)
forall a b. (a -> b) -> a -> b
$ StrictSeq (Tx (BabbageEra StandardCrypto))
-> TxSeq (BabbageEra StandardCrypto)
forall era. SupportsSegWit era => StrictSeq (Tx era) -> TxSeq era
CL.toTxSeq (StrictSeq (Tx (BabbageEra StandardCrypto))
 -> TxSeq (BabbageEra StandardCrypto))
-> StrictSeq (Tx (BabbageEra StandardCrypto))
-> TxSeq (BabbageEra StandardCrypto)
forall a b. (a -> b) -> a -> b
$ [ValidatedTx (BabbageEra StandardCrypto)]
-> StrictSeq (ValidatedTx (BabbageEra StandardCrypto))
forall a. [a] -> StrictSeq a
fromList ([ValidatedTx (BabbageEra StandardCrypto)]
 -> StrictSeq (ValidatedTx (BabbageEra StandardCrypto)))
-> [ValidatedTx (BabbageEra StandardCrypto)]
-> StrictSeq (ValidatedTx (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Validated (ValidatedTx (BabbageEra StandardCrypto))
-> ValidatedTx (BabbageEra StandardCrypto)
forall tx. Validated tx -> tx
extractTx (Validated (ValidatedTx (BabbageEra StandardCrypto))
 -> ValidatedTx (BabbageEra StandardCrypto))
-> (OnChainTx
    -> Validated (ValidatedTx (BabbageEra StandardCrypto)))
-> OnChainTx
-> ValidatedTx (BabbageEra StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainTx -> Validated (ValidatedTx (BabbageEra StandardCrypto))
OnChainTx -> Validated (Tx (BabbageEra StandardCrypto))
getOnChainTx (OnChainTx -> ValidatedTx (BabbageEra StandardCrypto))
-> Block -> [ValidatedTx (BabbageEra StandardCrypto)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block
block)

fromCardanoBlock :: CardanoBlock StandardCrypto -> Block
fromCardanoBlock :: CardanoBlock StandardCrypto -> Block
fromCardanoBlock (OC.BlockBabbage (Shelley.ShelleyBlock (CL.Block _ txSeq) ShelleyHash (ProtoCrypto (Praos StandardCrypto))
_)) = (ValidatedTx (BabbageEra StandardCrypto) -> OnChainTx)
-> [ValidatedTx (BabbageEra StandardCrypto)] -> Block
forall a b. (a -> b) -> [a] -> [b]
map (Validated (ValidatedTx (BabbageEra StandardCrypto)) -> OnChainTx
Validated (Tx (BabbageEra StandardCrypto)) -> OnChainTx
OnChainTx (Validated (ValidatedTx (BabbageEra StandardCrypto)) -> OnChainTx)
-> (ValidatedTx (BabbageEra StandardCrypto)
    -> Validated (ValidatedTx (BabbageEra StandardCrypto)))
-> ValidatedTx (BabbageEra StandardCrypto)
-> OnChainTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedTx (BabbageEra StandardCrypto)
-> Validated (ValidatedTx (BabbageEra StandardCrypto))
forall tx. tx -> Validated tx
unsafeMakeValidated) ([ValidatedTx (BabbageEra StandardCrypto)] -> Block)
-> (StrictSeq (ValidatedTx (BabbageEra StandardCrypto))
    -> [ValidatedTx (BabbageEra StandardCrypto)])
-> StrictSeq (ValidatedTx (BabbageEra StandardCrypto))
-> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (ValidatedTx (BabbageEra StandardCrypto))
-> [ValidatedTx (BabbageEra StandardCrypto)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (ValidatedTx (BabbageEra StandardCrypto)) -> Block)
-> StrictSeq (ValidatedTx (BabbageEra StandardCrypto)) -> Block
forall a b. (a -> b) -> a -> b
$ TxSeq (BabbageEra StandardCrypto)
-> StrictSeq (Tx (BabbageEra StandardCrypto))
forall era. SupportsSegWit era => TxSeq era -> StrictSeq (Tx era)
CL.fromTxSeq TxSeq (BabbageEra StandardCrypto)
txSeq
fromCardanoBlock CardanoBlock StandardCrypto
_ = []