{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Node.Startup where

import           Prelude

import           Data.Aeson (FromJSON, ToJSON)
import           Data.Map (Map)
import           Data.Text (Text, pack)
import           Data.Time.Clock (NominalDiffTime, UTCTime)
import           Data.Version (showVersion)
import           Data.Word (Word64)
import           GHC.Generics (Generic)

import           Network.HostName (getHostName)
import qualified Network.Socket as Socket

import           Cardano.Ledger.Shelley.Genesis (sgSystemStart)

import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Cardano.CanHardFork (shelleyLedgerConfig)
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Combinator.Degenerate
import           Ouroboros.Consensus.Ledger.Query (getSystemStart)
import           Ouroboros.Consensus.Node (pInfoConfig)
import           Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion,
                   BlockNodeToNodeVersion)
import           Ouroboros.Consensus.Shelley.Ledger.Ledger (shelleyLedgerGenesis)

import           Ouroboros.Network.Magic (NetworkMagic (..))
import           Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket,
                   NodeToClientVersion)
import           Ouroboros.Network.NodeToNode (DiffusionMode (..), NodeToNodeVersion)
import           Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint)
import           Ouroboros.Network.PeerSelection.Types (PeerAdvertise)
import           Ouroboros.Network.Subscription.Dns (DnsSubscriptionTarget (..))
import           Ouroboros.Network.Subscription.Ip (IPSubscriptionTarget (..))

import           Cardano.Api.Protocol.Types (BlockType (..), protocolInfo)
import           Cardano.Logging
import           Cardano.Node.Configuration.Socket
import           Cardano.Node.Protocol.Types (Protocol (..), SomeConsensusProtocol (..))

import           Cardano.Git.Rev (gitRev)
import           Paths_cardano_node (version)

data StartupTrace blk =
  -- | Log startup information.
  --
    StartupInfo
      [SocketOrSocketInfo Socket.SockAddr Socket.SockAddr]
      -- ^ node-to-node addresses
      (Maybe (SocketOrSocketInfo LocalSocket LocalAddress))
      -- ^ node-to-client socket path
      (Map NodeToNodeVersion (BlockNodeToNodeVersion blk))
      -- ^ supported node-to-node versions
      (Map NodeToClientVersion (BlockNodeToClientVersion blk))
      -- ^ supported node-to-client versions

  -- | Log peer-to-peer diffusion mode
  | StartupP2PInfo DiffusionMode

  | StartupTime UTCTime

  | StartupNetworkMagic NetworkMagic

  | StartupSocketConfigError SocketConfigError

  | StartupDBValidation

  -- | Log that the network configuration is being updated.
  --
  | NetworkConfigUpdate

  -- | Re-configuration of network config is not supported.
  --
  | NetworkConfigUpdateUnsupported

  -- | Log network configuration update error.
  --
  | NetworkConfigUpdateError Text

  -- | Log peer-to-peer network configuration, either on startup or when its
  -- updated.
  --
  | NetworkConfig [(Int, Map RelayAccessPoint PeerAdvertise)]
                  [RelayAccessPoint]
                  UseLedgerAfter

  -- | Warn when 'EnableP2P' is set.
  | P2PWarning

  -- | Warn that peer-to-peer requires
  -- 'TestEnableDevelopmentNetworkProtocols' to be set.
  --
  | P2PWarningDevelopementNetworkProtocols

  -- | Warn when 'TestEnableDevelopmentNetworkProtocols' is set.
  --
  | WarningDevelopmentNetworkProtocols [NodeToNodeVersion] [NodeToClientVersion]

  | BICommon BasicInfoCommon
  | BIShelley BasicInfoShelleyBased
  | BIByron BasicInfoByron
  | BINetwork BasicInfoNetwork

data BasicInfoCommon = BasicInfoCommon {
    BasicInfoCommon -> FilePath
biConfigPath    :: FilePath
  , BasicInfoCommon -> NetworkMagic
biNetworkMagic  :: NetworkMagic
  , BasicInfoCommon -> Text
biProtocol      :: Text
  , BasicInfoCommon -> Text
biVersion       :: Text
  , BasicInfoCommon -> Text
biCommit        :: Text
  , BasicInfoCommon -> UTCTime
biNodeStartTime :: UTCTime
  }

data BasicInfoShelleyBased = BasicInfoShelleyBased {
    BasicInfoShelleyBased -> Text
bisEra               :: Text
  , BasicInfoShelleyBased -> UTCTime
bisSystemStartTime   :: UTCTime
  , BasicInfoShelleyBased -> NominalDiffTime
bisSlotLength        :: NominalDiffTime
  , BasicInfoShelleyBased -> Word64
bisEpochLength       :: Word64
  , BasicInfoShelleyBased -> Word64
bisSlotsPerKESPeriod :: Word64
  }

data BasicInfoByron = BasicInfoByron {
    BasicInfoByron -> UTCTime
bibSystemStartTime :: UTCTime
  , BasicInfoByron -> NominalDiffTime
bibSlotLength      :: NominalDiffTime
  , BasicInfoByron -> Word64
bibEpochLength     :: Word64
  }

data BasicInfoNetwork = BasicInfoNetwork {
    BasicInfoNetwork -> [SocketOrSocketInfo SockAddr SockAddr]
niAddresses     :: [SocketOrSocketInfo Socket.SockAddr Socket.SockAddr]
  , BasicInfoNetwork -> DiffusionMode
niDiffusionMode :: DiffusionMode
  , BasicInfoNetwork -> [DnsSubscriptionTarget]
niDnsProducers  :: [DnsSubscriptionTarget]
  , BasicInfoNetwork -> IPSubscriptionTarget
niIpProducers   :: IPSubscriptionTarget
  }

data NodeInfo = NodeInfo
  { NodeInfo -> Text
niName            :: Text
  , NodeInfo -> Text
niProtocol        :: Text
  , NodeInfo -> Text
niVersion         :: Text
  , NodeInfo -> Text
niCommit          :: Text
  , NodeInfo -> UTCTime
niStartTime       :: UTCTime
  , NodeInfo -> UTCTime
niSystemStartTime :: UTCTime
  } deriving (NodeInfo -> NodeInfo -> Bool
(NodeInfo -> NodeInfo -> Bool)
-> (NodeInfo -> NodeInfo -> Bool) -> Eq NodeInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeInfo -> NodeInfo -> Bool
$c/= :: NodeInfo -> NodeInfo -> Bool
== :: NodeInfo -> NodeInfo -> Bool
$c== :: NodeInfo -> NodeInfo -> Bool
Eq, (forall x. NodeInfo -> Rep NodeInfo x)
-> (forall x. Rep NodeInfo x -> NodeInfo) -> Generic NodeInfo
forall x. Rep NodeInfo x -> NodeInfo
forall x. NodeInfo -> Rep NodeInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeInfo x -> NodeInfo
$cfrom :: forall x. NodeInfo -> Rep NodeInfo x
Generic, [NodeInfo] -> Encoding
[NodeInfo] -> Value
NodeInfo -> Encoding
NodeInfo -> Value
(NodeInfo -> Value)
-> (NodeInfo -> Encoding)
-> ([NodeInfo] -> Value)
-> ([NodeInfo] -> Encoding)
-> ToJSON NodeInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NodeInfo] -> Encoding
$ctoEncodingList :: [NodeInfo] -> Encoding
toJSONList :: [NodeInfo] -> Value
$ctoJSONList :: [NodeInfo] -> Value
toEncoding :: NodeInfo -> Encoding
$ctoEncoding :: NodeInfo -> Encoding
toJSON :: NodeInfo -> Value
$ctoJSON :: NodeInfo -> Value
ToJSON, Value -> Parser [NodeInfo]
Value -> Parser NodeInfo
(Value -> Parser NodeInfo)
-> (Value -> Parser [NodeInfo]) -> FromJSON NodeInfo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NodeInfo]
$cparseJSONList :: Value -> Parser [NodeInfo]
parseJSON :: Value -> Parser NodeInfo
$cparseJSON :: Value -> Parser NodeInfo
FromJSON, Int -> NodeInfo -> ShowS
[NodeInfo] -> ShowS
NodeInfo -> FilePath
(Int -> NodeInfo -> ShowS)
-> (NodeInfo -> FilePath) -> ([NodeInfo] -> ShowS) -> Show NodeInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NodeInfo] -> ShowS
$cshowList :: [NodeInfo] -> ShowS
show :: NodeInfo -> FilePath
$cshow :: NodeInfo -> FilePath
showsPrec :: Int -> NodeInfo -> ShowS
$cshowsPrec :: Int -> NodeInfo -> ShowS
Show)

docNodeInfoTraceEvent :: Documented NodeInfo
docNodeInfoTraceEvent :: Documented NodeInfo
docNodeInfoTraceEvent = [DocMsg NodeInfo] -> Documented NodeInfo
forall a. [DocMsg a] -> Documented a
Documented [
    Namespace -> [(Text, Text)] -> Text -> DocMsg NodeInfo
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NodeInfo"]
        []
        Text
"Basic information about this node collected at startup\
        \\n\
        \\n _niName_: Name of the node. \
        \\n _niProtocol_: Protocol which this nodes uses. \
        \\n _niVersion_: Software version which this node is using. \
        \\n _niStartTime_: Start time of this node. \
        \\n _niSystemStartTime_: How long did the start of the node took."
  ]

-- | Prepare basic info about the node. This info will be sent to 'cardano-tracer'.
prepareNodeInfo
  :: Protocol
  -> SomeConsensusProtocol
  -> TraceConfig
  -> UTCTime
  -> IO NodeInfo
prepareNodeInfo :: Protocol
-> SomeConsensusProtocol -> TraceConfig -> UTCTime -> IO NodeInfo
prepareNodeInfo Protocol
ptcl (SomeConsensusProtocol BlockType blk
whichP ProtocolInfoArgs IO blk
pForInfo) TraceConfig
tc UTCTime
nodeStartTime = do
  Text
nodeName <- IO Text
prepareNodeName
  NodeInfo -> IO NodeInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeInfo -> IO NodeInfo) -> NodeInfo -> IO NodeInfo
forall a b. (a -> b) -> a -> b
$ NodeInfo :: Text -> Text -> Text -> Text -> UTCTime -> UTCTime -> NodeInfo
NodeInfo
    { niName :: Text
niName            = Text
nodeName
    , niProtocol :: Text
niProtocol        = FilePath -> Text
pack (FilePath -> Text) -> (Protocol -> FilePath) -> Protocol -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Protocol -> FilePath
forall a. Show a => a -> FilePath
show (Protocol -> Text) -> Protocol -> Text
forall a b. (a -> b) -> a -> b
$ Protocol
ptcl
    , niVersion :: Text
niVersion         = FilePath -> Text
pack (FilePath -> Text) -> (Version -> FilePath) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> FilePath
showVersion (Version -> Text) -> Version -> Text
forall a b. (a -> b) -> a -> b
$ Version
version
    , niCommit :: Text
niCommit          = Text
gitRev
    , niStartTime :: UTCTime
niStartTime       = UTCTime
nodeStartTime
    , niSystemStartTime :: UTCTime
niSystemStartTime = UTCTime
systemStartTime
    }
 where
  cfg :: TopLevelConfig blk
cfg = ProtocolInfo IO blk -> TopLevelConfig blk
forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig (ProtocolInfo IO blk -> TopLevelConfig blk)
-> ProtocolInfo IO blk -> TopLevelConfig blk
forall a b. (a -> b) -> a -> b
$ ProtocolInfoArgs IO blk -> ProtocolInfo IO blk
forall (m :: * -> *) blk.
Protocol m blk =>
ProtocolInfoArgs m blk -> ProtocolInfo m blk
protocolInfo ProtocolInfoArgs IO blk
pForInfo

  systemStartTime :: UTCTime
  systemStartTime :: UTCTime
systemStartTime =
    case BlockType blk
whichP of
      BlockType blk
ByronBlockType ->
        UTCTime
getSystemStartByron
      BlockType blk
ShelleyBlockType ->
        let DegenLedgerConfig PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg
        in ShelleyPartialLedgerConfig StandardShelley -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
ShelleyPartialLedgerConfig StandardShelley
cfgShelley
      BlockType blk
CardanoBlockType ->
        let CardanoLedgerConfig PartialLedgerConfig ByronBlock
_ PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
cfgAllegra PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
cfgMary PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
cfgAlonzo PartialLedgerConfig
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
cfgBabbage = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg
        in [UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ UTCTime
getSystemStartByron
                   , ShelleyPartialLedgerConfig StandardShelley -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
ShelleyPartialLedgerConfig StandardShelley
cfgShelley
                   , ShelleyPartialLedgerConfig (AllegraEra StandardCrypto) -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
ShelleyPartialLedgerConfig (AllegraEra StandardCrypto)
cfgAllegra
                   , ShelleyPartialLedgerConfig (MaryEra StandardCrypto) -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
ShelleyPartialLedgerConfig (MaryEra StandardCrypto)
cfgMary
                   , ShelleyPartialLedgerConfig (AlonzoEra StandardCrypto) -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
ShelleyPartialLedgerConfig (AlonzoEra StandardCrypto)
cfgAlonzo
                   , ShelleyPartialLedgerConfig (BabbageEra StandardCrypto) -> UTCTime
forall era. ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley PartialLedgerConfig
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
ShelleyPartialLedgerConfig (BabbageEra StandardCrypto)
cfgBabbage
                   ]

  getSystemStartByron :: UTCTime
getSystemStartByron = SystemStart -> UTCTime
WCT.getSystemStart (SystemStart -> UTCTime)
-> (TopLevelConfig blk -> SystemStart)
-> TopLevelConfig blk
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart (BlockConfig blk -> SystemStart)
-> (TopLevelConfig blk -> BlockConfig blk)
-> TopLevelConfig blk
-> SystemStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock (TopLevelConfig blk -> UTCTime) -> TopLevelConfig blk -> UTCTime
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
cfg
  getSystemStartShelley :: ShelleyPartialLedgerConfig era -> UTCTime
getSystemStartShelley = ShelleyGenesis era -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
sgSystemStart (ShelleyGenesis era -> UTCTime)
-> (ShelleyPartialLedgerConfig era -> ShelleyGenesis era)
-> ShelleyPartialLedgerConfig era
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis (ShelleyLedgerConfig era -> ShelleyGenesis era)
-> (ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era)
-> ShelleyPartialLedgerConfig era
-> ShelleyGenesis era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
forall era.
ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
shelleyLedgerConfig

  prepareNodeName :: IO Text
prepareNodeName =
    case TraceConfig -> Maybe Text
tcNodeName TraceConfig
tc of
      Just Text
aName -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
aName
      Maybe Text
Nothing    -> FilePath -> Text
pack (FilePath -> Text) -> IO FilePath -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getHostName