module Hydra.Node.Run where

import Hydra.Prelude hiding (fromList)

import Cardano.Ledger.BaseTypes (Globals (..), boundRational, mkActiveSlotCoeff)
import Cardano.Ledger.Shelley.API (computeRandomnessStabilisationWindow, computeStabilityWindow)
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Hydra.API.Server (APIServerConfig (..), withAPIServer)
import Hydra.API.ServerOutputFilter (serverOutputFilter)
import Hydra.Cardano.Api (
  GenesisParameters (..),
  ProtocolParametersConversionError,
  ShelleyEra,
  SystemStart (..),
  toShelleyNetwork,
 )
import Hydra.Chain (maximumNumberOfParties)
import Hydra.Chain.CardanoClient (QueryPoint (..), queryGenesisParameters)
import Hydra.Chain.Direct (loadChainContext, mkTinyWallet, withDirectChain)
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.Chain.Offline (loadGenesisFile, withOfflineChain)
import Hydra.Events.FileBased (eventPairFromPersistenceIncremental)
import Hydra.Ledger.Cardano (cardanoLedger, newLedgerEnv)
import Hydra.Logging (Verbosity (..), traceWith, withTracer)
import Hydra.Logging.Messages (HydraLog (..))
import Hydra.Logging.Monitoring (withMonitoring)
import Hydra.Node (
  chainStateHistory,
  connect,
  hydrate,
  initEnvironment,
  runHydraNode,
  wireChainInput,
  wireClientInput,
  wireNetworkInput,
 )
import Hydra.Node.Network (NetworkConfiguration (..), withNetwork)
import Hydra.Options (
  ChainConfig (..),
  DirectChainConfig (..),
  InvalidOptions (..),
  LedgerConfig (..),
  OfflineChainConfig (..),
  RunOptions (..),
  validateRunOptions,
 )
import Hydra.Persistence (createPersistenceIncremental)
import Hydra.Tx.Environment (Environment (..))
import Hydra.Utils (readJsonFileThrow)

data ConfigurationException
  = -- XXX: this is not used
    ConfigurationException ProtocolParametersConversionError
  | InvalidOptionException InvalidOptions
  deriving stock (Int -> ConfigurationException -> ShowS
[ConfigurationException] -> ShowS
ConfigurationException -> FilePath
(Int -> ConfigurationException -> ShowS)
-> (ConfigurationException -> FilePath)
-> ([ConfigurationException] -> ShowS)
-> Show ConfigurationException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigurationException -> ShowS
showsPrec :: Int -> ConfigurationException -> ShowS
$cshow :: ConfigurationException -> FilePath
show :: ConfigurationException -> FilePath
$cshowList :: [ConfigurationException] -> ShowS
showList :: [ConfigurationException] -> ShowS
Show)

instance Exception ConfigurationException where
  displayException :: ConfigurationException -> FilePath
displayException = \case
    InvalidOptionException InvalidOptions
MaximumNumberOfPartiesExceeded ->
      FilePath
"Maximum number of parties is currently set to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
maximumNumberOfParties
    InvalidOptionException InvalidOptions
CardanoAndHydraKeysMissmatch ->
      FilePath
"Number of loaded cardano and hydra keys needs to match"
    ConfigurationException ProtocolParametersConversionError
err ->
      FilePath
"Incorrect protocol parameters configuration provided: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ProtocolParametersConversionError -> FilePath
forall b a. (Show a, IsString b) => a -> b
show ProtocolParametersConversionError
err

run :: RunOptions -> IO ()
run :: RunOptions -> IO ()
run RunOptions
opts = do
  (InvalidOptions -> IO ())
-> (() -> IO ()) -> Either InvalidOptions () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ConfigurationException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ConfigurationException -> IO ())
-> (InvalidOptions -> ConfigurationException)
-> InvalidOptions
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidOptions -> ConfigurationException
InvalidOptionException) () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InvalidOptions () -> IO ())
-> Either InvalidOptions () -> IO ()
forall a b. (a -> b) -> a -> b
$ RunOptions -> Either InvalidOptions ()
validateRunOptions RunOptions
opts
  Verbosity
-> (Tracer
      IO
      (HydraLog
         Tx
         (WithHost
            (TraceOuroborosNetwork
               (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
    -> IO ())
-> IO ()
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
Verbosity -> (Tracer m msg -> IO a) -> IO a
withTracer Verbosity
verbosity ((Tracer
    IO
    (HydraLog
       Tx
       (WithHost
          (TraceOuroborosNetwork
             (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
  -> IO ())
 -> IO ())
-> (Tracer
      IO
      (HydraLog
         Tx
         (WithHost
            (TraceOuroborosNetwork
               (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer' -> do
    Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
-> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer' (RunOptions
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
forall tx net. RunOptions -> HydraLog tx net
NodeOptions RunOptions
opts)
    Maybe PortNumber
-> Tracer
     IO
     (HydraLog
        Tx
        (WithHost
           (TraceOuroborosNetwork
              (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> (Tracer
      IO
      (HydraLog
         Tx
         (WithHost
            (TraceOuroborosNetwork
               (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
    -> IO ())
-> IO ()
forall (m :: * -> *) tx net.
(MonadIO m, MonadAsync m, IsTx tx, MonadMonotonicTime m) =>
Maybe PortNumber
-> Tracer m (HydraLog tx net)
-> (Tracer m (HydraLog tx net) -> m ())
-> m ()
withMonitoring Maybe PortNumber
monitoringPort Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer' ((Tracer
    IO
    (HydraLog
       Tx
       (WithHost
          (TraceOuroborosNetwork
             (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
  -> IO ())
 -> IO ())
-> (Tracer
      IO
      (HydraLog
         Tx
         (WithHost
            (TraceOuroborosNetwork
               (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer -> do
      env :: Environment
env@Environment{Party
party :: Party
$sel:party:Environment :: Environment -> Party
party, [Party]
otherParties :: [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties, SigningKey HydraKey
signingKey :: SigningKey HydraKey
$sel:signingKey:Environment :: Environment -> SigningKey HydraKey
signingKey} <- RunOptions -> IO Environment
initEnvironment RunOptions
opts
      -- Ledger
      PParams StandardConway
pparams <- (Value -> Parser (PParams StandardConway))
-> FilePath -> IO (PParams StandardConway)
forall a. (Value -> Parser a) -> FilePath -> IO a
readJsonFileThrow Value -> Parser (PParams StandardConway)
forall a. FromJSON a => Value -> Parser a
parseJSON (LedgerConfig -> FilePath
cardanoLedgerProtocolParametersFile LedgerConfig
ledgerConfig)
      Globals
globals <- ChainConfig -> IO Globals
getGlobalsForChain ChainConfig
chainConfig
      PParams StandardConway -> Globals -> (Ledger Tx -> IO ()) -> IO ()
forall {t}.
PParams StandardConway -> Globals -> (Ledger Tx -> t) -> t
withCardanoLedger PParams StandardConway
pparams Globals
globals ((Ledger Tx -> IO ()) -> IO ()) -> (Ledger Tx -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ledger Tx
ledger -> do
        -- Hydrate with event source and sinks
        (EventSource (StateEvent Tx) IO
eventSource, EventSink (StateEvent Tx) IO
filePersistenceSink) <-
          PersistenceIncremental (PersistedStateChange Tx) IO
-> IO
     (EventSource (StateEvent Tx) IO, EventSink (StateEvent Tx) IO)
forall tx (m :: * -> *).
(IsChainState tx, MonadSTM m) =>
PersistenceIncremental (PersistedStateChange tx) m
-> m (EventSource (StateEvent tx) m, EventSink (StateEvent tx) m)
eventPairFromPersistenceIncremental
            (PersistenceIncremental (PersistedStateChange Tx) IO
 -> IO
      (EventSource (StateEvent Tx) IO, EventSink (StateEvent Tx) IO))
-> IO (PersistenceIncremental (PersistedStateChange Tx) IO)
-> IO
     (EventSource (StateEvent Tx) IO, EventSink (StateEvent Tx) IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath
-> IO (PersistenceIncremental (PersistedStateChange Tx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
FilePath -> m (PersistenceIncremental a m)
createPersistenceIncremental (FilePath
persistenceDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/state")
        -- NOTE: Add any custom sink setup code here
        -- customSink <- createCustomSink
        let eventSinks :: [EventSink (StateEvent Tx) IO]
eventSinks =
              [ EventSink (StateEvent Tx) IO
filePersistenceSink
              -- NOTE: Add any custom sinks here
              -- , customSink
              ]
        DraftHydraNode Tx IO
wetHydraNode <- Tracer IO (HydraNodeLog Tx)
-> Environment
-> Ledger Tx
-> ChainStateType Tx
-> EventSource (StateEvent Tx) IO
-> [EventSink (StateEvent Tx) IO]
-> IO (DraftHydraNode Tx IO)
forall (m :: * -> *) tx.
(MonadDelay m, MonadLabelledSTM m, MonadAsync m, MonadThrow m,
 IsChainState tx) =>
Tracer m (HydraNodeLog tx)
-> Environment
-> Ledger tx
-> ChainStateType tx
-> EventSource (StateEvent tx) m
-> [EventSink (StateEvent tx) m]
-> m (DraftHydraNode tx m)
hydrate ((HydraNodeLog Tx
 -> HydraLog
      Tx
      (WithHost
         (TraceOuroborosNetwork
            (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer
     IO
     (HydraLog
        Tx
        (WithHost
           (TraceOuroborosNetwork
              (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer IO (HydraNodeLog Tx)
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog Tx
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
forall tx net. HydraNodeLog tx -> HydraLog tx net
Node Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer) Environment
env Ledger Tx
ledger ChainStateType Tx
initialChainState EventSource (StateEvent Tx) IO
eventSource [EventSink (StateEvent Tx) IO]
eventSinks
        -- Chain
        ChainStateHistory Tx -> ChainComponent Tx IO ()
withChain <- Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Environment
-> ChainConfig
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
prepareChainComponent Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer Environment
env ChainConfig
chainConfig
        ChainStateHistory Tx -> ChainComponent Tx IO ()
withChain (DraftHydraNode Tx IO -> ChainStateHistory Tx
forall tx (m :: * -> *).
DraftHydraNode tx m -> ChainStateHistory tx
chainStateHistory DraftHydraNode Tx IO
wetHydraNode) (DraftHydraNode Tx IO -> ChainEvent Tx -> IO ()
forall tx (m :: * -> *).
DraftHydraNode tx m -> ChainEvent tx -> m ()
wireChainInput DraftHydraNode Tx IO
wetHydraNode) ((Chain Tx IO -> IO ()) -> IO ())
-> (Chain Tx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Chain Tx IO
chain -> do
          -- API
          PersistenceIncremental (TimedServerOutput Tx) IO
apiPersistence <- FilePath -> IO (PersistenceIncremental (TimedServerOutput Tx) IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
FilePath -> m (PersistenceIncremental a m)
createPersistenceIncremental (FilePath -> IO (PersistenceIncremental (TimedServerOutput Tx) IO))
-> FilePath
-> IO (PersistenceIncremental (TimedServerOutput Tx) IO)
forall a b. (a -> b) -> a -> b
$ FilePath
persistenceDir FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/server-output"
          let apiServerConfig :: APIServerConfig
apiServerConfig = APIServerConfig{$sel:host:APIServerConfig :: IP
host = IP
apiHost, $sel:port:APIServerConfig :: PortNumber
port = PortNumber
apiPort, Maybe FilePath
tlsCertPath :: Maybe FilePath
$sel:tlsCertPath:APIServerConfig :: Maybe FilePath
tlsCertPath, Maybe FilePath
tlsKeyPath :: Maybe FilePath
$sel:tlsKeyPath:APIServerConfig :: Maybe FilePath
tlsKeyPath}
          APIServerConfig
-> Environment
-> Party
-> PersistenceIncremental (TimedServerOutput Tx) IO
-> Tracer IO APIServerLog
-> Chain Tx IO
-> PParams LedgerEra
-> ServerOutputFilter Tx
-> ServerComponent Tx IO ()
forall tx.
IsChainState tx =>
APIServerConfig
-> Environment
-> Party
-> PersistenceIncremental (TimedServerOutput tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> ServerComponent tx IO ()
withAPIServer APIServerConfig
apiServerConfig Environment
env Party
party PersistenceIncremental (TimedServerOutput Tx) IO
apiPersistence ((APIServerLog
 -> HydraLog
      Tx
      (WithHost
         (TraceOuroborosNetwork
            (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer
     IO
     (HydraLog
        Tx
        (WithHost
           (TraceOuroborosNetwork
              (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer IO APIServerLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap APIServerLog
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
forall tx net. APIServerLog -> HydraLog tx net
APIServer Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer) Chain Tx IO
chain PParams StandardConway
PParams LedgerEra
pparams ServerOutputFilter Tx
serverOutputFilter (DraftHydraNode Tx IO -> ClientInput Tx -> IO ()
forall tx (m :: * -> *).
DraftHydraNode tx m -> ClientInput tx -> m ()
wireClientInput DraftHydraNode Tx IO
wetHydraNode) ((Server Tx IO -> IO ()) -> IO ())
-> (Server Tx IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Server Tx IO
server -> do
            -- Network
            let networkConfiguration :: NetworkConfiguration IO
networkConfiguration = NetworkConfiguration{FilePath
persistenceDir :: FilePath
$sel:persistenceDir:NetworkConfiguration :: FilePath
persistenceDir, SigningKey HydraKey
signingKey :: SigningKey HydraKey
$sel:signingKey:NetworkConfiguration :: SigningKey HydraKey
signingKey, [Party]
otherParties :: [Party]
$sel:otherParties:NetworkConfiguration :: [Party]
otherParties, IP
host :: IP
$sel:host:NetworkConfiguration :: IP
host, PortNumber
port :: PortNumber
$sel:port:NetworkConfiguration :: PortNumber
port, [Host]
peers :: [Host]
$sel:peers:NetworkConfiguration :: [Host]
peers, NodeId
nodeId :: NodeId
$sel:nodeId:NetworkConfiguration :: NodeId
nodeId}
            Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> NetworkConfiguration IO
-> NetworkComponent IO (NetworkEvent (Message Tx)) (Message Tx) ()
forall tx.
IsTx tx =>
Tracer IO (LogEntry tx (Message tx))
-> NetworkConfiguration IO
-> NetworkComponent IO (NetworkEvent (Message tx)) (Message tx) ()
withNetwork Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer NetworkConfiguration IO
networkConfiguration (DraftHydraNode Tx IO
-> NetworkCallback (NetworkEvent (Message Tx)) IO
forall tx (m :: * -> *).
DraftHydraNode tx m
-> NetworkCallback (NetworkEvent (Message tx)) m
wireNetworkInput DraftHydraNode Tx IO
wetHydraNode) ((Network IO (Message Tx) -> IO ()) -> IO ())
-> (Network IO (Message Tx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Network IO (Message Tx)
network -> do
              -- Main loop
              Chain Tx IO
-> Network IO (Message Tx)
-> Server Tx IO
-> DraftHydraNode Tx IO
-> IO (HydraNode Tx IO)
forall (m :: * -> *) tx.
Monad m =>
Chain tx m
-> Network m (Message tx)
-> Server tx m
-> DraftHydraNode tx m
-> m (HydraNode tx m)
connect Chain Tx IO
chain Network IO (Message Tx)
network Server Tx IO
server DraftHydraNode Tx IO
wetHydraNode
                IO (HydraNode Tx IO) -> (HydraNode Tx IO -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HydraNode Tx IO -> IO ()
forall (m :: * -> *) tx.
(MonadCatch m, MonadAsync m, IsChainState tx) =>
HydraNode tx m -> m ()
runHydraNode
 where
  withCardanoLedger :: PParams StandardConway -> Globals -> (Ledger Tx -> t) -> t
withCardanoLedger PParams StandardConway
protocolParams Globals
globals Ledger Tx -> t
action =
    let ledgerEnv :: LedgerEnv LedgerEra
ledgerEnv = PParams LedgerEra -> LedgerEnv LedgerEra
newLedgerEnv PParams StandardConway
PParams LedgerEra
protocolParams
     in Ledger Tx -> t
action (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
globals LedgerEnv LedgerEra
ledgerEnv)

  prepareChainComponent :: Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Environment
-> ChainConfig
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
prepareChainComponent Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party} = \case
    Offline OfflineChainConfig
cfg ->
      (ChainStateHistory Tx -> ChainComponent Tx IO ())
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ChainStateHistory Tx -> ChainComponent Tx IO ())
 -> IO (ChainStateHistory Tx -> ChainComponent Tx IO ()))
-> (ChainStateHistory Tx -> ChainComponent Tx IO ())
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
forall a b. (a -> b) -> a -> b
$ NodeId
-> OfflineChainConfig
-> Party
-> ChainStateHistory Tx
-> ChainComponent Tx IO ()
forall a.
NodeId
-> OfflineChainConfig
-> Party
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withOfflineChain NodeId
nodeId OfflineChainConfig
cfg Party
party
    Direct DirectChainConfig
cfg -> do
      ChainContext
ctx <- DirectChainConfig -> Party -> IO ChainContext
loadChainContext DirectChainConfig
cfg Party
party
      TinyWallet IO
wallet <- Tracer IO DirectChainLog -> DirectChainConfig -> IO (TinyWallet IO)
mkTinyWallet ((DirectChainLog
 -> HydraLog
      Tx
      (WithHost
         (TraceOuroborosNetwork
            (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer
     IO
     (HydraLog
        Tx
        (WithHost
           (TraceOuroborosNetwork
              (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer IO DirectChainLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap DirectChainLog
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
forall tx net. DirectChainLog -> HydraLog tx net
DirectChain Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer) DirectChainConfig
cfg
      (ChainStateHistory Tx -> ChainComponent Tx IO ())
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ChainStateHistory Tx -> ChainComponent Tx IO ())
 -> IO (ChainStateHistory Tx -> ChainComponent Tx IO ()))
-> (ChainStateHistory Tx -> ChainComponent Tx IO ())
-> IO (ChainStateHistory Tx -> ChainComponent Tx IO ())
forall a b. (a -> b) -> a -> b
$ Tracer IO DirectChainLog
-> DirectChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO ()
forall a.
Tracer IO DirectChainLog
-> DirectChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withDirectChain ((DirectChainLog
 -> HydraLog
      Tx
      (WithHost
         (TraceOuroborosNetwork
            (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer
     IO
     (HydraLog
        Tx
        (WithHost
           (TraceOuroborosNetwork
              (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
-> Tracer IO DirectChainLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap DirectChainLog
-> HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx))))))
forall tx net. DirectChainLog -> HydraLog tx net
DirectChain Tracer
  IO
  (HydraLog
     Tx
     (WithHost
        (TraceOuroborosNetwork
           (Signed (ReliableMsg (Heartbeat (Message Tx)))))))
tracer) DirectChainConfig
cfg ChainContext
ctx TinyWallet IO
wallet

  RunOptions
    { Verbosity
verbosity :: Verbosity
$sel:verbosity:RunOptions :: RunOptions -> Verbosity
verbosity
    , Maybe PortNumber
monitoringPort :: Maybe PortNumber
$sel:monitoringPort:RunOptions :: RunOptions -> Maybe PortNumber
monitoringPort
    , FilePath
persistenceDir :: FilePath
$sel:persistenceDir:RunOptions :: RunOptions -> FilePath
persistenceDir
    , ChainConfig
chainConfig :: ChainConfig
$sel:chainConfig:RunOptions :: RunOptions -> ChainConfig
chainConfig
    , LedgerConfig
ledgerConfig :: LedgerConfig
$sel:ledgerConfig:RunOptions :: RunOptions -> LedgerConfig
ledgerConfig
    , IP
host :: IP
$sel:host:RunOptions :: RunOptions -> IP
host
    , PortNumber
port :: PortNumber
$sel:port:RunOptions :: RunOptions -> PortNumber
port
    , [Host]
peers :: [Host]
$sel:peers:RunOptions :: RunOptions -> [Host]
peers
    , NodeId
nodeId :: NodeId
$sel:nodeId:RunOptions :: RunOptions -> NodeId
nodeId
    , IP
apiHost :: IP
$sel:apiHost:RunOptions :: RunOptions -> IP
apiHost
    , PortNumber
apiPort :: PortNumber
$sel:apiPort:RunOptions :: RunOptions -> PortNumber
apiPort
    , Maybe FilePath
tlsCertPath :: Maybe FilePath
$sel:tlsCertPath:RunOptions :: RunOptions -> Maybe FilePath
tlsCertPath
    , Maybe FilePath
tlsKeyPath :: Maybe FilePath
$sel:tlsKeyPath:RunOptions :: RunOptions -> Maybe FilePath
tlsKeyPath
    } = RunOptions
opts

getGlobalsForChain :: ChainConfig -> IO Globals
getGlobalsForChain :: ChainConfig -> IO Globals
getGlobalsForChain = \case
  Offline OfflineChainConfig{Maybe FilePath
ledgerGenesisFile :: Maybe FilePath
$sel:ledgerGenesisFile:OfflineChainConfig :: OfflineChainConfig -> Maybe FilePath
ledgerGenesisFile} ->
    Maybe FilePath -> IO (GenesisParameters ShelleyEra)
loadGenesisFile Maybe FilePath
ledgerGenesisFile
      IO (GenesisParameters ShelleyEra)
-> (GenesisParameters ShelleyEra -> IO Globals) -> IO Globals
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenesisParameters ShelleyEra -> IO Globals
forall (m :: * -> *).
MonadThrow m =>
GenesisParameters ShelleyEra -> m Globals
newGlobals
  Direct DirectChainConfig{NetworkId
networkId :: NetworkId
$sel:networkId:DirectChainConfig :: DirectChainConfig -> NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectChainConfig :: DirectChainConfig -> SocketPath
nodeSocket} ->
    NetworkId
-> SocketPath -> QueryPoint -> IO (GenesisParameters ShelleyEra)
queryGenesisParameters NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip
      IO (GenesisParameters ShelleyEra)
-> (GenesisParameters ShelleyEra -> IO Globals) -> IO Globals
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenesisParameters ShelleyEra -> IO Globals
forall (m :: * -> *).
MonadThrow m =>
GenesisParameters ShelleyEra -> m Globals
newGlobals

data GlobalsTranslationException = GlobalsTranslationException
  deriving stock (GlobalsTranslationException -> GlobalsTranslationException -> Bool
(GlobalsTranslationException
 -> GlobalsTranslationException -> Bool)
-> (GlobalsTranslationException
    -> GlobalsTranslationException -> Bool)
-> Eq GlobalsTranslationException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
== :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
$c/= :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
/= :: GlobalsTranslationException -> GlobalsTranslationException -> Bool
Eq, Int -> GlobalsTranslationException -> ShowS
[GlobalsTranslationException] -> ShowS
GlobalsTranslationException -> FilePath
(Int -> GlobalsTranslationException -> ShowS)
-> (GlobalsTranslationException -> FilePath)
-> ([GlobalsTranslationException] -> ShowS)
-> Show GlobalsTranslationException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobalsTranslationException -> ShowS
showsPrec :: Int -> GlobalsTranslationException -> ShowS
$cshow :: GlobalsTranslationException -> FilePath
show :: GlobalsTranslationException -> FilePath
$cshowList :: [GlobalsTranslationException] -> ShowS
showList :: [GlobalsTranslationException] -> ShowS
Show)

instance Exception GlobalsTranslationException

-- | Create new L2 ledger 'Globals' from 'GenesisParameters'.
--
-- Throws at least 'GlobalsTranslationException'
newGlobals :: MonadThrow m => GenesisParameters ShelleyEra -> m Globals
newGlobals :: forall (m :: * -> *).
MonadThrow m =>
GenesisParameters ShelleyEra -> m Globals
newGlobals GenesisParameters ShelleyEra
genesisParameters = do
  case PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff (PositiveUnitInterval -> ActiveSlotCoeff)
-> Maybe PositiveUnitInterval -> Maybe ActiveSlotCoeff
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Maybe PositiveUnitInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
protocolParamActiveSlotsCoefficient of
    Maybe ActiveSlotCoeff
Nothing -> GlobalsTranslationException -> m Globals
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO GlobalsTranslationException
GlobalsTranslationException
    Just ActiveSlotCoeff
slotCoeff -> do
      let k :: Word64
k = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamSecurity
      Globals -> m Globals
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Globals -> m Globals) -> Globals -> m Globals
forall a b. (a -> b) -> a -> b
$
        Globals
          { activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff = ActiveSlotCoeff
slotCoeff
          , EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo
          , maxKESEvo :: Word64
maxKESEvo = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamMaxKESEvolutions
          , maxLovelaceSupply :: Word64
maxLovelaceSupply = Coin -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Coin
protocolParamMaxLovelaceSupply
          , networkId :: Network
networkId = NetworkId -> Network
toShelleyNetwork NetworkId
protocolParamNetworkId
          , quorum :: Word64
quorum = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamUpdateQuorum
          , randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow = Word64 -> ActiveSlotCoeff -> Word64
computeRandomnessStabilisationWindow Word64
k ActiveSlotCoeff
slotCoeff
          , securityParameter :: Word64
securityParameter = Word64
k
          , slotsPerKESPeriod :: Word64
slotsPerKESPeriod = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
protocolParamSlotsPerKESPeriod
          , stabilityWindow :: Word64
stabilityWindow = Word64 -> ActiveSlotCoeff -> Word64
computeStabilityWindow Word64
k ActiveSlotCoeff
slotCoeff
          , systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart UTCTime
protocolParamSystemStart
          }
 where
  GenesisParameters
    { Int
protocolParamSlotsPerKESPeriod :: Int
protocolParamSlotsPerKESPeriod :: forall era. GenesisParameters era -> Int
protocolParamSlotsPerKESPeriod
    , Int
protocolParamUpdateQuorum :: Int
protocolParamUpdateQuorum :: forall era. GenesisParameters era -> Int
protocolParamUpdateQuorum
    , Coin
protocolParamMaxLovelaceSupply :: Coin
protocolParamMaxLovelaceSupply :: forall era. GenesisParameters era -> Coin
protocolParamMaxLovelaceSupply
    , Int
protocolParamSecurity :: Int
protocolParamSecurity :: forall era. GenesisParameters era -> Int
protocolParamSecurity
    , Rational
protocolParamActiveSlotsCoefficient :: Rational
protocolParamActiveSlotsCoefficient :: forall era. GenesisParameters era -> Rational
protocolParamActiveSlotsCoefficient
    , UTCTime
protocolParamSystemStart :: UTCTime
protocolParamSystemStart :: forall era. GenesisParameters era -> UTCTime
protocolParamSystemStart
    , NetworkId
protocolParamNetworkId :: NetworkId
protocolParamNetworkId :: forall era. GenesisParameters era -> NetworkId
protocolParamNetworkId
    , Int
protocolParamMaxKESEvolutions :: Int
protocolParamMaxKESEvolutions :: forall era. GenesisParameters era -> Int
protocolParamMaxKESEvolutions
    , EpochSize
protocolParamEpochLength :: EpochSize
protocolParamEpochLength :: forall era. GenesisParameters era -> EpochSize
protocolParamEpochLength
    , NominalDiffTime
protocolParamSlotLength :: NominalDiffTime
protocolParamSlotLength :: forall era. GenesisParameters era -> NominalDiffTime
protocolParamSlotLength
    } = GenesisParameters ShelleyEra
genesisParameters
  -- NOTE: uses fixed epoch info for our L2 ledger
  epochInfo :: EpochInfo (Either Text)
epochInfo = EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
protocolParamEpochLength SlotLength
slotLength
  slotLength :: SlotLength
slotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
protocolParamSlotLength

identifyNode :: RunOptions -> RunOptions
identifyNode :: RunOptions -> RunOptions
identifyNode opt :: RunOptions
opt@RunOptions{$sel:verbosity:RunOptions :: RunOptions -> Verbosity
verbosity = Verbose Text
"HydraNode", NodeId
$sel:nodeId:RunOptions :: RunOptions -> NodeId
nodeId :: NodeId
nodeId} = RunOptions
opt{verbosity = Verbose $ "HydraNode-" <> show nodeId}
identifyNode RunOptions
opt = RunOptions
opt