{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE InstanceSigs         #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeData             #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Network.Ping
  ( PingOpts (..)
  , Address
  , cmdlineParser
  , PingMode (..)
  , LogFormat (..)
  , ColorMode (..)
  , LogMsg (..)
  , StatPoint (..)
  , ProtocolFlavour (..)
  , pingClients
  , mainnetMagic
  , NetworkMagic (..)
  ) where

import Control.Concurrent.Class.MonadMVar
import Control.Concurrent.Class.MonadSTM.Strict
import Control.DeepSeq (NFData)
import Control.Exception (SomeAsyncException (..))
import Control.Monad (unless, void, when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer, mkTracer, nullTracer, traceWith, (>$<))

import Codec.CBOR.Term qualified as CBOR
import Codec.Serialise qualified as Serialise
import Data.Aeson (KeyValue ((.=)), ToJSON (toJSON), Value, object)
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Text (encodeToLazyText)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS.Char
import Data.ByteString.Lazy qualified as BL
import Data.IP
import Data.List qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (All (..))
import Data.String (fromString)
import Data.TDigest (TDigest)
import Data.TDigest qualified as TDigest
import Data.Text (Text)
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.IO qualified as TL
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Word (Word16, Word32)
import Network.DNS qualified as DNS
import Network.Mux (MiniProtocolInfo (..))
import Network.Mux qualified as Mx
import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer)
import Network.Socket (AddrInfo, StructLinger (..))
import Network.Socket qualified as Socket
import Options.Applicative
import Options.Applicative.Help.Pretty qualified as Pretty
import System.Directory (doesFileExist)
import System.IO qualified as IO
import System.Random (initStdGen)
import Text.Printf (printf)
import Text.Read (readMaybe)

import Cardano.Network.Diffusion.Configuration (defaultChainSyncIdleTimeout)
import Cardano.Network.NodeToClient qualified as NodeToClient
import Cardano.Network.NodeToClient.Version
import Cardano.Network.NodeToNode qualified as NodeToNode
import Cardano.Network.NodeToNode.Version
import Cardano.Network.OrphanInstances ()
import Cardano.Network.PeerSelection (PeerSharing (..), PeerTrustable (..))
import Cardano.Network.Protocol.ChainSync.Client (ChainSyncClient)
import Cardano.Network.Protocol.ChainSync.Client qualified as ChainSync
import Cardano.Network.Protocol.ChainSync.Codec qualified as ChainSync
import Cardano.Network.Protocol.ChainSync.Codec.TimeLimits qualified as ChainSync
import Cardano.Network.Protocol.KeepAlive.Client (KeepAliveClient (..))
import Cardano.Network.Protocol.KeepAlive.Client qualified as KeepAlive
import Cardano.Network.Protocol.KeepAlive.Codec qualified as KeepAlive
import Cardano.Network.Protocol.KeepAlive.Type qualified as KeepAlive

import Ouroboros.Network.Block hiding (blockNo)
import Ouroboros.Network.ConnectionId
import Ouroboros.Network.Driver.Limits
import Ouroboros.Network.Protocol.Handshake hiding (Accept (..),
           RefuseReason (..))
import Ouroboros.Network.Util.ShowProxy

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

data ColorMode = ColorAuto | ColorNever | ColorAlways
  deriving (ColorMode -> ColorMode -> Bool
(ColorMode -> ColorMode -> Bool)
-> (ColorMode -> ColorMode -> Bool) -> Eq ColorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColorMode -> ColorMode -> Bool
== :: ColorMode -> ColorMode -> Bool
$c/= :: ColorMode -> ColorMode -> Bool
/= :: ColorMode -> ColorMode -> Bool
Eq, Int -> ColorMode -> FilePath -> FilePath
[ColorMode] -> FilePath -> FilePath
ColorMode -> FilePath
(Int -> ColorMode -> FilePath -> FilePath)
-> (ColorMode -> FilePath)
-> ([ColorMode] -> FilePath -> FilePath)
-> Show ColorMode
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ColorMode -> FilePath -> FilePath
showsPrec :: Int -> ColorMode -> FilePath -> FilePath
$cshow :: ColorMode -> FilePath
show :: ColorMode -> FilePath
$cshowList :: [ColorMode] -> FilePath -> FilePath
showList :: [ColorMode] -> FilePath -> FilePath
Show)


data PingMode =
    TipMode
    -- puery tip
  | PingMode
    -- ping
  | QueryMode
    -- query handshake parameters
  deriving (PingMode -> PingMode -> Bool
(PingMode -> PingMode -> Bool)
-> (PingMode -> PingMode -> Bool) -> Eq PingMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PingMode -> PingMode -> Bool
== :: PingMode -> PingMode -> Bool
$c/= :: PingMode -> PingMode -> Bool
/= :: PingMode -> PingMode -> Bool
Eq, Int -> PingMode -> FilePath -> FilePath
[PingMode] -> FilePath -> FilePath
PingMode -> FilePath
(Int -> PingMode -> FilePath -> FilePath)
-> (PingMode -> FilePath)
-> ([PingMode] -> FilePath -> FilePath)
-> Show PingMode
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> PingMode -> FilePath -> FilePath
showsPrec :: Int -> PingMode -> FilePath -> FilePath
$cshow :: PingMode -> FilePath
show :: PingMode -> FilePath
$cshowList :: [PingMode] -> FilePath -> FilePath
showList :: [PingMode] -> FilePath -> FilePath
Show)

type Port = Word

-- | There are three stages for resolving addresses.
--
-- 1. SRV might be a file path or a DNS name or an SRV record
-- 2. SRV was resolved as an SRV record, if not
-- 3. try to resolve it as a DNS name
-- 4. if failed, try to use it as a file path
--
-- See `resolveAddress`
--
type data Stage = Unresolved ResolvedSRVOrFilePath | Resolved
type data ResolvedSRVOrFilePath = SRVOrFilePathUnresolved | SRVOrFilePathResolved


data Address (stage :: Stage) where
    FilePath :: FilePath -> Address Resolved

    FilePathOrDomain
             :: String
             -> Address (Unresolved SRVOrFilePathUnresolved)

    Domain   :: DNS.Domain
             -> Port
             -> Address (Unresolved SRVOrFilePathResolved)

    SRV      :: String
             -> Address (Unresolved SRVOrFilePathUnresolved)

    IP       :: IP
             -> Port
             -> Address resolved


showIPWithPort :: IP -> Port -> String
showIPWithPort :: IP -> Port -> FilePath
showIPWithPort ip :: IP
ip@IPv4{} Port
port = IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port
showIPWithPort ip :: IP
ip@IPv6{} Port
port = FilePath
"[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"]:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port

instance Show (Address Resolved) where
  show :: Address Resolved -> String
  show :: Address Resolved -> FilePath
show (IP IP
ip Port
port)    = IP -> Port -> FilePath
showIPWithPort IP
ip Port
port
  show (FilePath FilePath
path) = FilePath
path

deriving instance Eq (Address Resolved)
deriving instance Ord (Address Resolved)


data PingOpts = PingOpts
  { PingOpts -> Word32
pingOptsCount     :: Word32
    -- ^ Number of messages to send to the server
  , PingOpts -> NetworkMagic
pingOptsMagic     :: NetworkMagic
    -- ^ The network magic to use for all connections
  , PingOpts -> LogFormat
pingOptsJson      :: LogFormat
    -- ^ Print output in JSON
  , PingOpts -> Bool
pingOptsQuiet     :: Bool
    -- ^ Less verbose output
  , PingOpts -> PingMode
pingOptsMode      :: PingMode
    -- ^ Ping mode
  , PingOpts -> FilePath
pingOptsSRVPrefix :: String
    -- ^ SRV prefix
  , PingOpts -> ColorMode
pingOptsColor     :: ColorMode
    -- ^ Colorised output
  } -- deriving (Eq, Show)

mainnetMagic :: NetworkMagic
mainnetMagic :: NetworkMagic
mainnetMagic = Word32 -> NetworkMagic
NetworkMagic Word32
764824073

pingOptsParser :: Parser PingOpts
pingOptsParser :: Parser PingOpts
pingOptsParser =
  Word32
-> NetworkMagic
-> LogFormat
-> Bool
-> PingMode
-> FilePath
-> ColorMode
-> PingOpts
PingOpts
    (Word32
 -> NetworkMagic
 -> LogFormat
 -> Bool
 -> PingMode
 -> FilePath
 -> ColorMode
 -> PingOpts)
-> Parser Word32
-> Parser
     (NetworkMagic
      -> LogFormat
      -> Bool
      -> PingMode
      -> FilePath
      -> ColorMode
      -> PingOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Word32 -> Mod OptionFields Word32 -> Parser Word32
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Word32
forall a. Read a => ReadM a
auto
        (  FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"count"
        Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Word32
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'c'
        Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. FilePath -> Mod f a
help ([FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat
                [ FilePath
"Stop after sending count requests and receiving count responses.  "
                , FilePath
"If this option is not specified, ping will operate until interrupted.  "
                ])
        Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"COUNT"
        Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> Word32 -> Mod OptionFields Word32
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Word32
forall a. Bounded a => a
maxBound
        Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Word32
forall a (f :: * -> *). Show a => Mod f a
showDefault
        )
    Parser
  (NetworkMagic
   -> LogFormat
   -> Bool
   -> PingMode
   -> FilePath
   -> ColorMode
   -> PingOpts)
-> Parser NetworkMagic
-> Parser
     (LogFormat
      -> Bool -> PingMode -> FilePath -> ColorMode -> PingOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM NetworkMagic
-> Mod OptionFields NetworkMagic -> Parser NetworkMagic
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> ReadM Word32 -> ReadM NetworkMagic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Word32
forall a. Read a => ReadM a
auto)
        (  FilePath -> Mod OptionFields NetworkMagic
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"network-magic"
        Mod OptionFields NetworkMagic
-> Mod OptionFields NetworkMagic -> Mod OptionFields NetworkMagic
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields NetworkMagic
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'm'
        Mod OptionFields NetworkMagic
-> Mod OptionFields NetworkMagic -> Mod OptionFields NetworkMagic
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields NetworkMagic
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Network magic."
        Mod OptionFields NetworkMagic
-> Mod OptionFields NetworkMagic -> Mod OptionFields NetworkMagic
forall a. Semigroup a => a -> a -> a
<> NetworkMagic -> Mod OptionFields NetworkMagic
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value NetworkMagic
mainnetMagic
        Mod OptionFields NetworkMagic
-> Mod OptionFields NetworkMagic -> Mod OptionFields NetworkMagic
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields NetworkMagic
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MAGIC"
        Mod OptionFields NetworkMagic
-> Mod OptionFields NetworkMagic -> Mod OptionFields NetworkMagic
forall a. Semigroup a => a -> a -> a
<> (NetworkMagic -> FilePath) -> Mod OptionFields NetworkMagic
forall a (f :: * -> *). (a -> FilePath) -> Mod f a
showDefaultWith (Word32 -> FilePath
forall a. Show a => a -> FilePath
show (Word32 -> FilePath)
-> (NetworkMagic -> Word32) -> NetworkMagic -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkMagic -> Word32
unNetworkMagic)
        )
    Parser
  (LogFormat
   -> Bool -> PingMode -> FilePath -> ColorMode -> PingOpts)
-> Parser LogFormat
-> Parser (Bool -> PingMode -> FilePath -> ColorMode -> PingOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogFormat
-> LogFormat -> Mod FlagFields LogFormat -> Parser LogFormat
forall a. a -> a -> Mod FlagFields a -> Parser a
flag  LogFormat
AsText LogFormat
AsJSON
        (  FilePath -> Mod FlagFields LogFormat
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"json"
        Mod FlagFields LogFormat
-> Mod FlagFields LogFormat -> Mod FlagFields LogFormat
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields LogFormat
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'j'
        Mod FlagFields LogFormat
-> Mod FlagFields LogFormat -> Mod FlagFields LogFormat
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields LogFormat
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"JSON output flag."
        )
    Parser (Bool -> PingMode -> FilePath -> ColorMode -> PingOpts)
-> Parser Bool
-> Parser (PingMode -> FilePath -> ColorMode -> PingOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
False Bool
True
        (  FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"quiet"
        Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'q'
        Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Quiet flag, CSV/JSON only output."
        )
    Parser (PingMode -> FilePath -> ColorMode -> PingOpts)
-> Parser PingMode -> Parser (FilePath -> ColorMode -> PingOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM PingMode -> Mod OptionFields PingMode -> Parser PingMode
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM PingMode
pingMode
        (  FilePath -> Mod OptionFields PingMode
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"mode"
        Mod OptionFields PingMode
-> Mod OptionFields PingMode -> Mod OptionFields PingMode
forall a. Semigroup a => a -> a -> a
<> Maybe (Doc AnsiStyle) -> Mod OptionFields PingMode
forall (f :: * -> *) a. Maybe (Doc AnsiStyle) -> Mod f a
helpDoc (Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just (Doc AnsiStyle -> Maybe (Doc AnsiStyle))
-> Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
Pretty.hang Int
2 (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
                 Doc AnsiStyle
"Mode, either ping, tip or query:"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.softline
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"ping  - send pings via keep-alive protocol (node-to-node only),"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.softline
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"tip   - query tip via chain-sync protocol (node-to-node / node-to-client),"
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.softline
              Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"query - query handshake parameters (node-to-node / node-to-client)."
           )
        Mod OptionFields PingMode
-> Mod OptionFields PingMode -> Mod OptionFields PingMode
forall a. Semigroup a => a -> a -> a
<> PingMode -> Mod OptionFields PingMode
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value PingMode
PingMode
        Mod OptionFields PingMode
-> Mod OptionFields PingMode -> Mod OptionFields PingMode
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields PingMode
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"MODE"
        )
    Parser (FilePath -> ColorMode -> PingOpts)
-> Parser FilePath -> Parser (ColorMode -> PingOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str
        (   FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"srv-prefix"
         Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Prefix that will be added to an SRV service name"
         Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value FilePath
"_cardano._tcp"
         Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"SRV_PREFIX"
         Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields FilePath
forall a (f :: * -> *). Show a => Mod f a
showDefault
        )
    Parser (ColorMode -> PingOpts)
-> Parser ColorMode -> Parser PingOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM ColorMode -> Mod OptionFields ColorMode -> Parser ColorMode
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM ColorMode
colorMode
        (   FilePath -> Mod OptionFields ColorMode
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"color"
         Mod OptionFields ColorMode
-> Mod OptionFields ColorMode -> Mod OptionFields ColorMode
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ColorMode
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Colorized output: auto, never or always."
         Mod OptionFields ColorMode
-> Mod OptionFields ColorMode -> Mod OptionFields ColorMode
forall a. Semigroup a => a -> a -> a
<> ColorMode -> Mod OptionFields ColorMode
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ColorMode
ColorAuto
         Mod OptionFields ColorMode
-> Mod OptionFields ColorMode -> Mod OptionFields ColorMode
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ColorMode
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"COLOR"
         Mod OptionFields ColorMode
-> Mod OptionFields ColorMode -> Mod OptionFields ColorMode
forall a. Semigroup a => a -> a -> a
<> (ColorMode -> FilePath) -> Mod OptionFields ColorMode
forall a (f :: * -> *). (a -> FilePath) -> Mod f a
showDefaultWith (\case { ColorMode
ColorAuto -> FilePath
"auto"; ColorMode
ColorNever -> FilePath
"never"; ColorMode
ColorAlways -> FilePath
"always" })
        )
  where
    pingMode :: ReadM PingMode
    pingMode :: ReadM PingMode
pingMode =
      (FilePath -> Either FilePath PingMode) -> ReadM PingMode
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath PingMode) -> ReadM PingMode)
-> (FilePath -> Either FilePath PingMode) -> ReadM PingMode
forall a b. (a -> b) -> a -> b
$ \case
        FilePath
"tip" -> PingMode -> Either FilePath PingMode
forall a b. b -> Either a b
Right PingMode
TipMode
        FilePath
"ping" -> PingMode -> Either FilePath PingMode
forall a b. b -> Either a b
Right PingMode
PingMode
        FilePath
"query" -> PingMode -> Either FilePath PingMode
forall a b. b -> Either a b
Right PingMode
QueryMode
        FilePath
_ -> FilePath -> Either FilePath PingMode
forall a b. a -> Either a b
Left FilePath
"unexpected string"

    colorMode :: ReadM ColorMode
    colorMode :: ReadM ColorMode
colorMode =
      (FilePath -> Either FilePath ColorMode) -> ReadM ColorMode
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath ColorMode) -> ReadM ColorMode)
-> (FilePath -> Either FilePath ColorMode) -> ReadM ColorMode
forall a b. (a -> b) -> a -> b
$ \case
        FilePath
"auto"   -> ColorMode -> Either FilePath ColorMode
forall a b. b -> Either a b
Right ColorMode
ColorAuto
        FilePath
"never"  -> ColorMode -> Either FilePath ColorMode
forall a b. b -> Either a b
Right ColorMode
ColorNever
        FilePath
"always" -> ColorMode -> Either FilePath ColorMode
forall a b. b -> Either a b
Right ColorMode
ColorAlways
        FilePath
_        -> FilePath -> Either FilePath ColorMode
forall a b. a -> Either a b
Left FilePath
"expected auto, never or always"


argParser :: Parser [Address (Unresolved SRVOrFilePathUnresolved)]
argParser :: Parser [Address (Unresolved SRVOrFilePathUnresolved)]
argParser =
    Parser (Address (Unresolved SRVOrFilePathUnresolved))
-> Parser [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser (Address (Unresolved SRVOrFilePathUnresolved))
addrParser
  where
    addrParser :: Parser (Address (Unresolved SRVOrFilePathUnresolved))
    addrParser :: Parser (Address (Unresolved SRVOrFilePathUnresolved))
addrParser =
        ReadM (Address (Unresolved SRVOrFilePathUnresolved))
-> Mod
     ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
-> Parser (Address (Unresolved SRVOrFilePathUnresolved))
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument
          (     (IP -> Port -> Address (Unresolved SRVOrFilePathUnresolved))
-> (IP, Port) -> Address (Unresolved SRVOrFilePathUnresolved)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IP -> Port -> Address (Unresolved SRVOrFilePathUnresolved)
forall (resolved :: Stage). IP -> Port -> Address resolved
IP ((IP, Port) -> Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (IP, Port)
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM (IP, Port)
readIPv4AndPort
            ReadM (Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall a. ReadM a -> ReadM a -> ReadM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (IP -> Port -> Address (Unresolved SRVOrFilePathUnresolved))
-> (IP, Port) -> Address (Unresolved SRVOrFilePathUnresolved)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IP -> Port -> Address (Unresolved SRVOrFilePathUnresolved)
forall (resolved :: Stage). IP -> Port -> Address resolved
IP ((IP, Port) -> Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (IP, Port)
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM (IP, Port)
readIPv6AndPort
            ReadM (Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall a. ReadM a -> ReadM a -> ReadM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>                ReadM (Address (Unresolved SRVOrFilePathUnresolved))
readDomainNameOrFilePath
          )
          (  FilePath
-> Mod
     ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"List of IP/DNS/SRV address and ports or UNIX socket paths, e.g. 127.0.0.1:3001 [::1]:3001 example.org:3001."
          Mod ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
-> Mod
     ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
-> Mod
     ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
forall a. Semigroup a => a -> a -> a
<> FilePath
-> Mod
     ArgumentFields (Address (Unresolved SRVOrFilePathUnresolved))
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"ADDRS"
          )
      where
        -- note: `Read` instances for `IP`, `IPv4`, `IPv6` expect no trailing
        -- characters after the address, thus we need to find the split position
        -- first.

        -- parse IPv4 address and port in a form `127.0.0.1:3001`
        readIPv4AndPort :: ReadM (IP, Port)
        readIPv4AndPort :: ReadM (IP, Port)
readIPv4AndPort =
          (FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port)
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port))
-> (FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port)
forall a b. (a -> b) -> a -> b
$ \FilePath
s -> do
            case Char -> FilePath -> Maybe (FilePath, FilePath)
splitWith Char
':' FilePath
s of
              Maybe (FilePath, FilePath)
Nothing -> FilePath -> Either FilePath (IP, Port)
forall a b. a -> Either a b
Left FilePath
s
              Just (FilePath
addrStr, FilePath
portStr) ->
                Either FilePath (IP, Port)
-> ((IP, Port) -> Either FilePath (IP, Port))
-> Maybe (IP, Port)
-> Either FilePath (IP, Port)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath (IP, Port)
forall a b. a -> Either a b
Left FilePath
s) (IP, Port) -> Either FilePath (IP, Port)
forall a b. b -> Either a b
Right (Maybe (IP, Port) -> Either FilePath (IP, Port))
-> Maybe (IP, Port) -> Either FilePath (IP, Port)
forall a b. (a -> b) -> a -> b
$
                (,) (IP -> Port -> (IP, Port))
-> Maybe IP -> Maybe (Port -> (IP, Port))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe IP
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
addrStr
                    Maybe (Port -> (IP, Port)) -> Maybe Port -> Maybe (IP, Port)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Maybe Port
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
portStr

        -- parse IPv6 address and port in a form `[::1]:3001` or a UNIX file path
        readIPv6AndPort :: ReadM (IP, Port)
        readIPv6AndPort :: ReadM (IP, Port)
readIPv6AndPort =
          (FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port)
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port))
-> (FilePath -> Either FilePath (IP, Port)) -> ReadM (IP, Port)
forall a b. (a -> b) -> a -> b
$ \FilePath
s ->
            case FilePath
s of
              (Char
'[':FilePath
s') ->
                 case Char -> FilePath -> Maybe (FilePath, FilePath)
splitWith Char
']' FilePath
s' of
                   Just (FilePath
addrStr, Char
':' : FilePath
portStr) ->
                     Either FilePath (IP, Port)
-> ((IP, Port) -> Either FilePath (IP, Port))
-> Maybe (IP, Port)
-> Either FilePath (IP, Port)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath (IP, Port)
forall a b. a -> Either a b
Left FilePath
s) (IP, Port) -> Either FilePath (IP, Port)
forall a b. b -> Either a b
Right (Maybe (IP, Port) -> Either FilePath (IP, Port))
-> Maybe (IP, Port) -> Either FilePath (IP, Port)
forall a b. (a -> b) -> a -> b
$
                     (,) (IP -> Port -> (IP, Port))
-> Maybe IP -> Maybe (Port -> (IP, Port))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe IP
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
addrStr
                         Maybe (Port -> (IP, Port)) -> Maybe Port -> Maybe (IP, Port)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Maybe Port
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
portStr
                   Maybe (FilePath, FilePath)
_ -> FilePath -> Either FilePath (IP, Port)
forall a b. a -> Either a b
Left FilePath
s
              FilePath
_ -> FilePath -> Either FilePath (IP, Port)
forall a b. a -> Either a b
Left FilePath
s

        readDomainNameOrFilePath :: ReadM (Address (Unresolved SRVOrFilePathUnresolved))
        readDomainNameOrFilePath :: ReadM (Address (Unresolved SRVOrFilePathUnresolved))
readDomainNameOrFilePath = (FilePath
 -> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved)))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath
  -> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved)))
 -> ReadM (Address (Unresolved SRVOrFilePathUnresolved)))
-> (FilePath
    -> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved)))
-> ReadM (Address (Unresolved SRVOrFilePathUnresolved))
forall a b. (a -> b) -> a -> b
$ \FilePath
s ->
          case (Char -> Bool) -> FilePath -> Maybe Char
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') FilePath
s of
            -- not an `SRV` record
            Just Char
_  -> Address (Unresolved SRVOrFilePathUnresolved)
-> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved))
forall a b. b -> Either a b
Right (FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
FilePathOrDomain FilePath
s)
            Maybe Char
Nothing -> Address (Unresolved SRVOrFilePathUnresolved)
-> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved))
forall a b. b -> Either a b
Right (FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
SRV FilePath
s)

cmdlineParser :: Parser (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)])
cmdlineParser :: Parser (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)])
cmdlineParser = (,) (PingOpts
 -> [Address (Unresolved SRVOrFilePathUnresolved)]
 -> (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)]))
-> Parser PingOpts
-> Parser
     ([Address (Unresolved SRVOrFilePathUnresolved)]
      -> (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PingOpts
pingOptsParser Parser
  ([Address (Unresolved SRVOrFilePathUnresolved)]
   -> (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)]))
-> Parser [Address (Unresolved SRVOrFilePathUnresolved)]
-> Parser
     (PingOpts, [Address (Unresolved SRVOrFilePathUnresolved)])
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Address (Unresolved SRVOrFilePathUnresolved)]
argParser


-- | Log messages to stdout.
--
data LogMsg = LogChainSyncTip PingTip
            | LogStatPoint StatPoint
            | LogNodeToClientVersionData NodeToClientVersion (Either Text NodeToClientVersionData)
            | LogNodeToNodeVersionData   NodeToNodeVersion   (Either Text NodeToNodeVersionData)
  deriving Int -> LogMsg -> FilePath -> FilePath
[LogMsg] -> FilePath -> FilePath
LogMsg -> FilePath
(Int -> LogMsg -> FilePath -> FilePath)
-> (LogMsg -> FilePath)
-> ([LogMsg] -> FilePath -> FilePath)
-> Show LogMsg
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> LogMsg -> FilePath -> FilePath
showsPrec :: Int -> LogMsg -> FilePath -> FilePath
$cshow :: LogMsg -> FilePath
show :: LogMsg -> FilePath
$cshowList :: [LogMsg] -> FilePath -> FilePath
showList :: [LogMsg] -> FilePath -> FilePath
Show

-- | Log messages to stderr.
--
data PingWarning = FilePathDoesNotExist FilePath
                 | DNSError DNS.Domain DNS.DNSError
                 | DNSResolution DNS.Domain [IP] Word
                 | MissingPort IP
                 | Error SomeException
                 | ConnectError Socket.SockAddr SomeException


formatPingWarning :: PingWarning -> String
formatPingWarning :: PingWarning -> FilePath
formatPingWarning PingWarning
msg = PingWarning -> FilePath
severity PingWarning
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PingWarning -> FilePath
fn PingWarning
msg
  where
    fn :: PingWarning -> FilePath
fn (FilePathDoesNotExist FilePath
path)
      = FilePath
"file path " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not exist"
    fn (DNSError ByteString
domain DNSError
err)
      = [FilePath] -> FilePath
unwords
      [ FilePath
"dns:"
      , ByteString -> FilePath
BS.Char.unpack ByteString
domain
      , DNSError -> FilePath
forall a. Show a => a -> FilePath
show DNSError
err
      ]
    fn (DNSResolution ByteString
domain [IP]
ips Port
port)
      = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ ByteString -> FilePath
BS.Char.unpack ByteString
domain
      , FilePath
": "
      , FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
", " ((IP -> Port -> FilePath) -> Port -> IP -> FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip IP -> Port -> FilePath
showIPWithPort Port
port (IP -> FilePath) -> [IP] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IP]
ips)
      ]
    fn (MissingPort IP
ip)
      = FilePath
"missing port for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip
    fn (Error SomeException
err)
      = SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
    fn (ConnectError SockAddr
sockAddr SomeException
err)
      = FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-47s %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
sockAddr) (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err)

    severity :: PingWarning -> String
    severity :: PingWarning -> FilePath
severity = \case
        FilePathDoesNotExist{} -> FilePath
warning
        DNSError{}             -> FilePath
warning
        DNSResolution{}        -> FilePath
forall a. Monoid a => a
mempty
        MissingPort{}          -> FilePath
warning
        Error{}                -> FilePath
warning
        ConnectError{}         -> FilePath
warning
      where
        warning :: FilePath
warning = FilePath
"WARNING: "


instance ToText LogMsg where
  toText :: LogMsg -> Text
toText (LogChainSyncTip PingTip
tip) = FilePath -> Text
TL.pack (PingTip -> FilePath
forall a. Show a => a -> FilePath
show PingTip
tip)
  toText (LogStatPoint StatPoint
point) = FilePath -> Text
TL.pack (StatPoint -> FilePath
forall a. Show a => a -> FilePath
show StatPoint
point)
  toText (LogNodeToClientVersionData NodeToClientVersion
version Either Text NodeToClientVersionData
versionData)
    = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
      [ NodeToClientVersion -> FilePath
forall a. Show a => a -> FilePath
show NodeToClientVersion
version
      , (Text -> FilePath)
-> (NodeToClientVersionData -> FilePath)
-> Either Text NodeToClientVersionData
-> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> FilePath
TL.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict) NodeToClientVersionData -> FilePath
showNodeToClientVersionData Either Text NodeToClientVersionData
versionData
      ]
    where
      showNodeToClientVersionData :: NodeToClientVersionData -> String
      showNodeToClientVersionData :: NodeToClientVersionData -> FilePath
showNodeToClientVersionData
        (NodeToClientVersionData NetworkMagic
networkMagic Bool
query)
        = [FilePath] -> FilePath
unwords
          [ NetworkMagic -> FilePath
forall a. Show a => a -> FilePath
show NetworkMagic
networkMagic
          , Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
query
          ]
  toText (LogNodeToNodeVersionData NodeToNodeVersion
version Either Text NodeToNodeVersionData
versionData)
    = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
      [ NodeToNodeVersion -> FilePath
forall a. Show a => a -> FilePath
show NodeToNodeVersion
version
      , (Text -> FilePath)
-> (NodeToNodeVersionData -> FilePath)
-> Either Text NodeToNodeVersionData
-> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> FilePath
TL.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict) NodeToNodeVersionData -> FilePath
showNodeToNodeVersionData Either Text NodeToNodeVersionData
versionData
      ]
    where
      showNodeToNodeVersionData :: NodeToNodeVersionData -> String
      showNodeToNodeVersionData :: NodeToNodeVersionData -> FilePath
showNodeToNodeVersionData
        (NodeToNodeVersionData
          NetworkMagic
networkMagic
          DiffusionMode
diffusionMode
          PeerSharing
peerSharing
          Bool
query
          PerasSupport
perasSupport
        )
        = [FilePath] -> FilePath
unwords
          [ NetworkMagic -> FilePath
forall a. Show a => a -> FilePath
show NetworkMagic
networkMagic
          , DiffusionMode -> FilePath
forall a. Show a => a -> FilePath
show DiffusionMode
diffusionMode
          , PeerSharing -> FilePath
forall a. Show a => a -> FilePath
show PeerSharing
peerSharing
          , Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
query
          , PerasSupport -> FilePath
forall a. Show a => a -> FilePath
show PerasSupport
perasSupport
          ]


instance ToJSON LogMsg where
  toJSON :: LogMsg -> Value
toJSON (LogChainSyncTip PingTip
tip) = PingTip -> Value
forall a. ToJSON a => a -> Value
toJSON PingTip
tip
  toJSON (LogStatPoint StatPoint
point) = StatPoint -> Value
forall a. ToJSON a => a -> Value
toJSON StatPoint
point
  toJSON (LogNodeToClientVersionData NodeToClientVersion
version Either Text NodeToClientVersionData
versionData)
    = [Pair] -> Value
object [ FilePath -> Key
forall a. IsString a => FilePath -> a
fromString (NodeToClientVersion -> FilePath
forall a. Show a => a -> FilePath
show NodeToClientVersion
version) Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text -> Value)
-> (NodeToClientVersionData -> Value)
-> Either Text NodeToClientVersionData
-> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value
forall a. ToJSON a => a -> Value
toJSON NodeToClientVersionData -> Value
forall a. ToJSON a => a -> Value
toJSON Either Text NodeToClientVersionData
versionData ]
  toJSON (LogNodeToNodeVersionData NodeToNodeVersion
version Either Text NodeToNodeVersionData
versionData)
    = [Pair] -> Value
object [ FilePath -> Key
forall a. IsString a => FilePath -> a
fromString (NodeToNodeVersion -> FilePath
forall a. Show a => a -> FilePath
show NodeToNodeVersion
version) Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text -> Value)
-> (NodeToNodeVersionData -> Value)
-> Either Text NodeToNodeVersionData
-> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value
forall a. ToJSON a => a -> Value
toJSON NodeToNodeVersionData -> Value
forall a. ToJSON a => a -> Value
toJSON Either Text NodeToNodeVersionData
versionData ]


sduTimeout :: DiffTime
sduTimeout :: DiffTime
sduTimeout = DiffTime
30

data PingTip = PingTip {
    PingTip -> Double
ptRtt     :: !Double
  , PingTip -> ByteString
ptHash    :: !ByteString
  , PingTip -> BlockNo
ptBlockNo :: !BlockNo
  , PingTip -> SlotNo
ptSlotNo  :: !SlotNo
  }

hexStr :: ByteString -> String
hexStr :: ByteString -> FilePath
hexStr = (Word8 -> FilePath -> FilePath)
-> FilePath -> ByteString -> FilePath
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr (\Word8
b -> FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
(<>) (FilePath -> Word8 -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%02x" Word8
b)) FilePath
""

instance Show PingTip where
  show :: PingTip -> FilePath
show PingTip{Double
ByteString
BlockNo
SlotNo
ptRtt :: PingTip -> Double
ptHash :: PingTip -> ByteString
ptBlockNo :: PingTip -> BlockNo
ptSlotNo :: PingTip -> SlotNo
ptRtt :: Double
ptHash :: ByteString
ptBlockNo :: BlockNo
ptSlotNo :: SlotNo
..} =
    FilePath -> Double -> FilePath -> Word64 -> Word64 -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%6.3fs, %-64s, %9d, %10d"
           Double
ptRtt
           (ByteString -> FilePath
hexStr ByteString
ptHash)
           (BlockNo -> Word64
unBlockNo BlockNo
ptBlockNo)
           (SlotNo -> Word64
unSlotNo SlotNo
ptSlotNo)

instance ToJSON PingTip where
  toJSON :: PingTip -> Value
toJSON PingTip{Double
ByteString
BlockNo
SlotNo
ptRtt :: PingTip -> Double
ptHash :: PingTip -> ByteString
ptBlockNo :: PingTip -> BlockNo
ptSlotNo :: PingTip -> SlotNo
ptRtt :: Double
ptHash :: ByteString
ptBlockNo :: BlockNo
ptSlotNo :: SlotNo
..} =
    [Pair] -> Value
object [
        Key
"rtt"     Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
ptRtt
      , Key
"hash"    Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> FilePath
hexStr ByteString
ptHash
      , Key
"blockNo" Key -> BlockNo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BlockNo
ptBlockNo
      , Key
"slotNo"  Key -> SlotNo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SlotNo
ptSlotNo
      ]

data StatPoint = StatPoint
  { StatPoint -> UTCTime
spTimestamp :: UTCTime
    -- ^ time-stamp of the sample value
  , StatPoint -> Word16
spCookie    :: Word16
    -- ^ sample number
  , StatPoint -> Double
spSample    :: Double
    -- ^ current sample value
  , StatPoint -> Double
spMedian    :: Double
    -- ^ median value
  , StatPoint -> Double
spP90       :: Double
    -- ^ 90 percentile
  , StatPoint -> Double
spMean      :: Double
    -- ^ mean value
  , StatPoint -> Double
spMin       :: Double
    -- ^ minimal value
  , StatPoint -> Double
spMax       :: Double
    -- ^ maximal value
  , StatPoint -> Double
spStd       :: Double
    -- ^ standard deviation
  }

instance Show StatPoint where
  show :: StatPoint -> String
  show :: StatPoint -> FilePath
show StatPoint {Double
Word16
UTCTime
spTimestamp :: StatPoint -> UTCTime
spCookie :: StatPoint -> Word16
spSample :: StatPoint -> Double
spMedian :: StatPoint -> Double
spP90 :: StatPoint -> Double
spMean :: StatPoint -> Double
spMin :: StatPoint -> Double
spMax :: StatPoint -> Double
spStd :: StatPoint -> Double
spTimestamp :: UTCTime
spCookie :: Word16
spSample :: Double
spMedian :: Double
spP90 :: Double
spMean :: Double
spMin :: Double
spMax :: Double
spStd :: Double
..} =
    FilePath
-> FilePath
-> Word16
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-31s %6d, %6.3f, %6.3f, %6.3f, %6.3f, %6.3f, %6.3f, %6.3f"
      (UTCTime -> FilePath
forall t. ISO8601 t => t -> FilePath
iso8601Show UTCTime
spTimestamp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
",")
      Word16
spCookie Double
spSample Double
spMedian Double
spP90 Double
spMean Double
spMin Double
spMax Double
spStd

statPointHeader :: String
statPointHeader :: FilePath
statPointHeader = FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-46s %30s, %6s, %6s, %6s, %6s, %6s, %6s, %6s, %6s"
                         (FilePath
"host," :: String)
                         (FilePath
"timestamp" :: String)
                         (FilePath
"cookie" :: String)
                         (FilePath
"sample" :: String)
                         (FilePath
"median" :: String)
                         (FilePath
"p90"    :: String)
                         (FilePath
"mean"   :: String)
                         (FilePath
"min"   :: String)
                         (FilePath
"max"   :: String)
                         (FilePath
"std"   :: String)

tipHeader :: String
tipHeader :: FilePath
tipHeader = FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-47s %6s, %64s, %9s, %10s"
                   (FilePath
"host,"   :: String)
                   (FilePath
"rtt"     :: String)
                   (FilePath
"hash"    :: String)
                   (FilePath
"blockNo" :: String)
                   (FilePath
"slotNo"  :: String)

instance ToJSON StatPoint where
  toJSON :: StatPoint -> Value
  toJSON :: StatPoint -> Value
toJSON StatPoint {Double
Word16
UTCTime
spTimestamp :: StatPoint -> UTCTime
spCookie :: StatPoint -> Word16
spSample :: StatPoint -> Double
spMedian :: StatPoint -> Double
spP90 :: StatPoint -> Double
spMean :: StatPoint -> Double
spMin :: StatPoint -> Double
spMax :: StatPoint -> Double
spStd :: StatPoint -> Double
spTimestamp :: UTCTime
spCookie :: Word16
spSample :: Double
spMedian :: Double
spP90 :: Double
spMean :: Double
spMin :: Double
spMax :: Double
spStd :: Double
..} =
    [Pair] -> Value
object
      [ Key
"timestamp" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
spTimestamp
      , Key
"cookie"    Key -> Word16 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word16
spCookie
      , Key
"sample"    Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spSample
      , Key
"median"    Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spMedian
      , Key
"p90"       Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spP90
      , Key
"mean"      Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spMean
      , Key
"min"       Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spMin
      , Key
"max"       Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spMax
      , Key
"std"       Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double
spStd
      ]

toStatPoint :: UTCTime -> Word16 -> Double -> TDigest 5 -> StatPoint
toStatPoint :: UTCTime -> Word16 -> Double -> TDigest 5 -> StatPoint
toStatPoint UTCTime
ts Word16
cookie Double
sample TDigest 5
td =
  StatPoint
    { spTimestamp :: UTCTime
spTimestamp   = UTCTime
ts
    , spCookie :: Word16
spCookie      = Word16
cookie
    , spSample :: Double
spSample      = Double
sample
    , spMedian :: Double
spMedian      = Double -> Double
quantile' Double
0.5
    , spP90 :: Double
spP90         = Double -> Double
quantile' Double
0.9
    , spMean :: Double
spMean        = Double
mean'
    , spMin :: Double
spMin         = TDigest 5 -> Double
forall (comp :: Nat). TDigest comp -> Double
TDigest.minimumValue TDigest 5
td
    , spMax :: Double
spMax         = TDigest 5 -> Double
forall (comp :: Nat). TDigest comp -> Double
TDigest.maximumValue TDigest 5
td
    , spStd :: Double
spStd         = Double
stddev'
    }
  where
    quantile' :: Double -> Double
    quantile' :: Double -> Double
quantile' Double
q = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (Double -> TDigest 5 -> Maybe Double
forall (comp :: Nat). Double -> TDigest comp -> Maybe Double
TDigest.quantile Double
q TDigest 5
td)

    mean' :: Double
    mean' :: Double
mean' = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (TDigest 5 -> Maybe Double
forall (comp :: Nat). TDigest comp -> Maybe Double
TDigest.mean TDigest 5
td)

    stddev' :: Double
    stddev' :: Double
stddev' = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (TDigest 5 -> Maybe Double
forall (comp :: Nat). TDigest comp -> Maybe Double
TDigest.stddev TDigest 5
td)


keepAliveDelay :: DiffTime
keepAliveDelay :: DiffTime
keepAliveDelay = DiffTime
1


-- | An idle timeout applied before closing the connection, to let the other
-- side exit cleanly.
idleTimeout :: DiffTime
idleTimeout :: DiffTime
idleTimeout = DiffTime
1


data PingClientError
  = PingClientProtocolLimitFailure ProtocolLimitFailure
  -- ^ protocol limit error

  | forall versionNumber.
    Show versionNumber
  => PingClientHandshakeProtocolError (HandshakeProtocolError versionNumber) (Address Resolved)
  -- ^ handshake protocol error

deriving instance Show PingClientError

instance Exception PingClientError where
  displayException :: PingClientError -> FilePath
displayException (PingClientProtocolLimitFailure ProtocolLimitFailure
err) =
    ProtocolLimitFailure -> FilePath
forall e. Exception e => e -> FilePath
displayException ProtocolLimitFailure
err
  displayException (PingClientHandshakeProtocolError HandshakeProtocolError versionNumber
err Address Resolved
addr) =
    FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s handshake error: %s" (Address Resolved -> FilePath
forall a. Show a => a -> FilePath
show Address Resolved
addr) (HandshakeProtocolError versionNumber -> FilePath
forall a. Show a => a -> FilePath
show HandshakeProtocolError versionNumber
err)

data ProtocolFlavour version versionData where
    NodeToNode   :: ProtocolFlavour NodeToNodeVersion   NodeToNodeVersionData
    NodeToClient :: ProtocolFlavour NodeToClientVersion NodeToClientVersionData

--
-- ChainSync Tip Sampling
--

-- We don't need blocks, headers or points, so we just go away with any valid
-- CBOR term.  As a result:
-- NOTE: the `chainSync` below is used for both `NodeToNode` and `NodeToClient`
-- protocols.
type ChainSyncHeader = CBOR.Term
type ChainSyncPoint  = CBOR.Term
data ChainSyncBlock
type instance HeaderHash ChainSyncBlock = ByteString
instance ShowProxy ChainSyncBlock where
type ChainSyncTip = Tip ChainSyncBlock
instance StandardHash ChainSyncBlock


-- A `ChainSyncClient` that finds the current `Tip` over `node-to-node`
-- or `node-to-client` protocol.
chainSyncClient
  :: PingOpts
  -> Signal
  -> HeaderVar
  -> Tracer IO LogMsg
  -> ChainSyncClient ChainSyncHeader ChainSyncPoint ChainSyncTip IO ()
chainSyncClient :: PingOpts
-> Signal
-> HeaderVar
-> Tracer IO LogMsg
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
chainSyncClient PingOpts
opts sig :: Signal
sig@Signal { IO ()
signalReadiness :: IO ()
signalReadiness :: Signal -> IO ()
signalReadiness } HeaderVar
headerVar Tracer IO LogMsg
stdout =
    IO
  (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSync.ChainSyncClient (IO
   (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
 -> ChainSyncClient
      ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall a b. (a -> b) -> a -> b
$ do
      IO ()
signalReadiness
      Time
-> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
go (Time
 -> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> IO Time
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  where
    go :: Time
       -> ChainSync.ClientStIdle ChainSyncHeader ChainSyncPoint ChainSyncTip IO ()
    go :: Time
-> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
go Time
start = [ChainSyncHeader]
-> ClientStIntersect
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
-> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
ChainSync.SendMsgFindIntersect []
       ChainSync.ClientStIntersect {
         recvMsgIntersectFound :: ChainSyncHeader
-> ChainSyncTip
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
ChainSync.recvMsgIntersectFound = \ChainSyncHeader
_ ChainSyncTip
_tip ->
           IO
  (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSync.ChainSyncClient (IO
   (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
 -> ChainSyncClient
      ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall a b. (a -> b) -> a -> b
$ do
             -- this should not happen, as we send an empty list of points
             ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
 -> IO
      (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()))
-> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
forall a b. (a -> b) -> a -> b
$ ()
-> ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
ChainSync.SendMsgDone (),
         recvMsgIntersectNotFound :: ChainSyncTip
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
ChainSync.recvMsgIntersectNotFound = \ChainSyncTip
tip ->
           IO
  (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSync.ChainSyncClient (IO
   (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
 -> ChainSyncClient
      ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> IO
     (ClientStIdle ChainSyncHeader ChainSyncHeader ChainSyncTip IO ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
forall a b. (a -> b) -> a -> b
$ do
             end <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
             let (ptSlotNo, ptHash, ptBlockNo) = case tip of
                   ChainSyncTip
TipGenesis              -> (SlotNo
0, ByteString
forall a. Monoid a => a
mempty, BlockNo
0)
                   Tip SlotNo
slotNo HeaderHash ChainSyncBlock
hash BlockNo
blockNo -> (SlotNo
slotNo, ByteString
HeaderHash ChainSyncBlock
hash, BlockNo
blockNo)
                 pingTip = PingTip {
                   ptRtt :: Double
ptRtt  = Time -> Time -> Double
toSample Time
end Time
start,
                   ByteString
ptHash :: ByteString
ptHash :: ByteString
ptHash,
                   BlockNo
ptBlockNo :: BlockNo
ptBlockNo :: BlockNo
ptBlockNo,
                   SlotNo
ptSlotNo :: SlotNo
ptSlotNo :: SlotNo
ptSlotNo
                 }
             awaitReadiness sig
             printHeader opts headerVar tipHeader
             traceWith stdout (LogChainSyncTip pingTip)
             return $ ChainSync.SendMsgDone ()
       }


--
-- KeepAlive RTT sampling
--

keepAliveClient
  :: PingOpts
  -> Signal
  -> HeaderVar
  -- ^ stat header MVar
  -> Tracer IO LogMsg
  -> TDigest 5
  -> KeepAliveClient IO ()
keepAliveClient :: PingOpts
-> Signal
-> HeaderVar
-> Tracer IO LogMsg
-> TDigest 5
-> KeepAliveClient IO ()
keepAliveClient opts :: PingOpts
opts@PingOpts { Word32
pingOptsCount :: PingOpts -> Word32
pingOptsCount :: Word32
pingOptsCount } Signal
sig HeaderVar
headerVar Tracer IO LogMsg
stdout TDigest 5
td0 =
    IO (KeepAliveClientSt IO ()) -> KeepAliveClient IO ()
forall (m :: * -> *) a.
m (KeepAliveClientSt m a) -> KeepAliveClient m a
KeepAliveClient (IO (KeepAliveClientSt IO ()) -> KeepAliveClient IO ())
-> IO (KeepAliveClientSt IO ()) -> KeepAliveClient IO ()
forall a b. (a -> b) -> a -> b
$ TDigest 5 -> Word32 -> IO (KeepAliveClientSt IO ())
loop TDigest 5
td0 Word32
0
  where
    -- we keep sending  keep alive message from the start, but we output
    -- measurements only when all clients are ready.  This is to make the output
    -- clean.  We cannot await for all clients to be ready, since some
    -- connections might be shutdown
    loop :: TDigest 5
         -> Word32
         -> IO (KeepAlive.KeepAliveClientSt IO ())
    loop :: TDigest 5 -> Word32 -> IO (KeepAliveClientSt IO ())
loop TDigest 5
_td Word32
cookie
      | Word32
cookie Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
pingOptsCount
      = KeepAliveClientSt IO () -> IO (KeepAliveClientSt IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeepAliveClientSt IO () -> IO (KeepAliveClientSt IO ()))
-> KeepAliveClientSt IO () -> IO (KeepAliveClientSt IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> KeepAliveClientSt IO ()
forall (m :: * -> *) a. m a -> KeepAliveClientSt m a
KeepAlive.SendMsgDone (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    loop TDigest 5
td Word32
cookie = do
      start <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      let cookie16 :: Word16
          cookie16 = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cookie
      return $ KeepAlive.SendMsgKeepAlive (KeepAlive.Cookie cookie16) $ do
        end <- getMonotonicTime
        now <- getCurrentTime
        ready <- signalAndGetReadiness sig
        if ready
          then do
            printHeader opts headerVar statPointHeader
            let rtt = Time -> Time -> Double
toSample Time
end Time
start
                td' = Double -> TDigest 5 -> TDigest 5
forall (comp :: Nat).
KnownNat comp =>
Double -> TDigest comp -> TDigest comp
TDigest.insert Double
rtt TDigest 5
td
                point = UTCTime -> Word16 -> Double -> TDigest 5 -> StatPoint
toStatPoint UTCTime
now Word16
cookie16 Double
rtt TDigest 5
td'
            traceWith stdout $ LogStatPoint point
            threadDelay keepAliveDelay
            loop td' (cookie + 1)
          else do
            -- we keep updating the measurements but we don't show them, other
            -- clients are still connecting or negotiating their connection.
            let rtt = Time -> Time -> Double
toSample Time
end Time
start
                td' = Double -> TDigest 5 -> TDigest 5
forall (comp :: Nat).
KnownNat comp =>
Double -> TDigest comp -> TDigest comp
TDigest.insert Double
rtt TDigest 5
td
            threadDelay keepAliveDelay
            loop td' cookie


--
-- Ping Client
--

resolveAddress :: Tracer IO PingWarning
               -> DNS.Resolver
               -> PingOpts
               -> Address (Unresolved fpResolved)
               -> IO [Address Resolved]

-- 1. Resolve an SRV records
resolveAddress :: forall (fpResolved :: ResolvedSRVOrFilePath).
Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved fpResolved)
-> IO [Address Resolved]
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver opts :: PingOpts
opts@PingOpts { pingOptsSRVPrefix :: PingOpts -> FilePath
pingOptsSRVPrefix = FilePath
srvPrefix } (SRV FilePath
dns) = do
  let hostname :: ByteString
hostname = FilePath -> ByteString
BS.Char.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ case FilePath
srvPrefix of
                                  [] -> FilePath
dns
                                  FilePath
_  -> FilePath
srvPrefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dns
  r <- Resolver -> ByteString -> TYPE -> IO (Either DNSError DNSMessage)
DNS.lookupRaw Resolver
resolver ByteString
hostname TYPE
DNS.SRV
  case r >>= flip DNS.fromDNSMessage selectSRV of
    Left DNSError
err -> do
      Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (PingWarning -> IO ()) -> PingWarning -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> DNSError -> PingWarning
DNSError ByteString
hostname DNSError
err
      -- try resolve the SRV as a domain:port or a filepath
      Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved SRVOrFilePathUnresolved)
-> IO [Address Resolved]
forall (fpResolved :: ResolvedSRVOrFilePath).
Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved fpResolved)
-> IO [Address Resolved]
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts (FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
FilePathOrDomain FilePath
dns)
    Right [(ByteString, Word16, Word16, Word16, Word32)]
services ->
      [[Address Resolved]] -> [Address Resolved]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Address Resolved]] -> [Address Resolved])
-> IO [[Address Resolved]] -> IO [Address Resolved]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Address (Unresolved SRVOrFilePathResolved)
 -> IO [Address Resolved])
-> [Address (Unresolved SRVOrFilePathResolved)]
-> IO [[Address Resolved]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved SRVOrFilePathResolved)
-> IO [Address Resolved]
forall (fpResolved :: ResolvedSRVOrFilePath).
Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved fpResolved)
-> IO [Address Resolved]
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts)
        [ ByteString -> Port -> Address (Unresolved SRVOrFilePathResolved)
Domain ByteString
domain (Word16 -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port)
        | (ByteString
domain, Word16
_, Word16
_, Word16
port, Word32
_ttl)  <- [(ByteString, Word16, Word16, Word16, Word32)]
services
        ]
  where
    selectSRV :: DNSMessage -> [(ByteString, Word16, Word16, Word16, Word32)]
selectSRV DNS.DNSMessage { Answers
answer :: Answers
answer :: DNSMessage -> Answers
DNS.answer } =
      [ (ByteString
domain', Word16
priority', Word16
weight', Word16
port, Word32
ttl)
      | DNS.ResourceRecord {
          rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_SRV Word16
priority' Word16
weight' Word16
port ByteString
domain',
          rrttl :: ResourceRecord -> Word32
DNS.rrttl = Word32
ttl
        } <- Answers
answer
      ]

-- 2. Resolved domain name or file path
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts (FilePathOrDomain FilePath
path) =
   case Char -> FilePath -> Maybe (FilePath, FilePath)
splitWith Char
':' FilePath
path
           Maybe (FilePath, FilePath)
-> ((FilePath, FilePath) -> Maybe (FilePath, Port))
-> Maybe (FilePath, Port)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(FilePath
dnsStr, FilePath
portStr) -> (FilePath
dnsStr,) (Port -> (FilePath, Port)) -> Maybe Port -> Maybe (FilePath, Port)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe Port
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
portStr
     of
     Just (FilePath
dnsname, Port
port) ->
       -- try resolve as a domain name
       Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved SRVOrFilePathResolved)
-> IO [Address Resolved]
forall (fpResolved :: ResolvedSRVOrFilePath).
Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved fpResolved)
-> IO [Address Resolved]
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts (ByteString -> Port -> Address (Unresolved SRVOrFilePathResolved)
Domain (FilePath -> ByteString
BS.Char.pack FilePath
dnsname) Port
port)
        IO [Address Resolved]
-> ([Address Resolved] -> IO [Address Resolved])
-> IO [Address Resolved]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          [] ->
            -- dns query failed, let's try if it is a file path
            FilePath -> IO Bool
doesFileExist FilePath
path IO Bool -> (Bool -> IO [Address Resolved]) -> IO [Address Resolved]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
True -> [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath -> Address Resolved
FilePath FilePath
path]
              Bool
False -> do
                Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (FilePath -> PingWarning
FilePathDoesNotExist FilePath
path)
                [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          [Address Resolved]
addrs -> [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Address Resolved]
addrs
     Maybe (FilePath, Port)
Nothing ->
       FilePath -> IO Bool
doesFileExist FilePath
path IO Bool -> (Bool -> IO [Address Resolved]) -> IO [Address Resolved]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         Bool
True ->
           [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath -> Address Resolved
FilePath FilePath
path]
         Bool
False -> do
           Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (FilePath -> PingWarning
FilePathDoesNotExist FilePath
path)
           [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- 3. Resolve domain names
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts { Bool
pingOptsQuiet :: PingOpts -> Bool
pingOptsQuiet :: Bool
pingOptsQuiet } (Domain ByteString
hostname Port
port) = do
  a <- ([IPv4] -> [IP]) -> Either DNSError [IPv4] -> Either DNSError [IP]
forall a b. (a -> b) -> Either DNSError a -> Either DNSError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IPv4 -> IP) -> [IPv4] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map IPv4 -> IP
IPv4) (Either DNSError [IPv4] -> Either DNSError [IP])
-> IO (Either DNSError [IPv4]) -> IO (Either DNSError [IP])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Resolver -> ByteString -> IO (Either DNSError [IPv4])
DNS.lookupA Resolver
resolver ByteString
hostname
  aaaa <- fmap (map IPv6) <$> DNS.lookupAAAA resolver hostname
  case a <>: aaaa of
    Left DNSError
err -> do
      Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (PingWarning -> IO ()) -> PingWarning -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> DNSError -> PingWarning
DNSError ByteString
hostname DNSError
err
      [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Right [IP]
ips -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pingOptsQuiet (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (PingWarning -> IO ()) -> PingWarning -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [IP] -> Port -> PingWarning
DNSResolution ByteString
hostname [IP]
ips Port
port
      [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ IP -> Port -> Address Resolved
forall (resolved :: Stage). IP -> Port -> Address resolved
IP IP
ip Port
port | IP
ip <- [IP]
ips ]
  where
    (<>:) :: Either e [a] -> Either e [a] -> Either e [a]
    (Left e
e) <>: :: forall e a. Either e [a] -> Either e [a] -> Either e [a]
<>: Left{}    = e -> Either e [a]
forall a b. a -> Either a b
Left e
e
    Right [a]
as <>: Left{}    = [a] -> Either e [a]
forall a b. b -> Either a b
Right [a]
as
    Left{}   <>: Right [a]
as  = [a] -> Either e [a]
forall a b. b -> Either a b
Right [a]
as
    Right [a]
as <>: Right [a]
as' = [a] -> Either e [a]
forall a b. b -> Either a b
Right ([a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as')

-- 4. Return ip address
resolveAddress Tracer IO PingWarning
_stderr Resolver
_ PingOpts
_ (IP IP
addr Port
port) = [Address Resolved] -> IO [Address Resolved]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [IP -> Port -> Address Resolved
forall (resolved :: Stage). IP -> Port -> Address resolved
IP IP
addr Port
port]


pingClients
  :: PingOpts
  -> [Address (Unresolved SRVOrFilePathUnresolved)]
  -> IO ()
pingClients :: PingOpts -> [Address (Unresolved SRVOrFilePathUnresolved)] -> IO ()
pingClients opts :: PingOpts
opts@PingOpts { LogFormat
pingOptsJson :: PingOpts -> LogFormat
pingOptsJson :: LogFormat
pingOptsJson } [Address (Unresolved SRVOrFilePathUnresolved)]
addresses = do
    stdoutLock <- () -> IO (MVar IO ())
forall a. a -> IO (MVar IO a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar ()
    IO.hSetBuffering IO.stdout IO.LineBuffering
    let stdout :: Tracer IO (WithHost LogMsg)
        stdout = (WithHost LogMsg -> IO ()) -> Tracer IO (WithHost LogMsg)
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer ((WithHost LogMsg -> IO ()) -> Tracer IO (WithHost LogMsg))
-> (WithHost LogMsg -> IO ()) -> Tracer IO (WithHost LogMsg)
forall a b. (a -> b) -> a -> b
$ \WithHost LogMsg
msg -> MVar IO () -> (() -> IO ()) -> IO ()
forall a b. MVar IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar ()
MVar IO ()
stdoutLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> Text -> IO ()
TL.putStrLn (LogFormat -> WithHost LogMsg -> Text
forall a. (ToText a, ToJSON a) => LogFormat -> a -> Text
format LogFormat
pingOptsJson WithHost LogMsg
msg)

    stderrLock <- newMVar ()
    IO.hSetBuffering IO.stderr IO.LineBuffering
    let stderr :: Tracer IO PingWarning
        stderr = (PingWarning -> IO ()) -> Tracer IO PingWarning
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer ((PingWarning -> IO ()) -> Tracer IO PingWarning)
-> (PingWarning -> IO ()) -> Tracer IO PingWarning
forall a b. (a -> b) -> a -> b
$ \PingWarning
msg -> MVar IO () -> (() -> IO ()) -> IO ()
forall a b. MVar IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadMVar m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar ()
MVar IO ()
stderrLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
          case PingWarning
msg of
            -- Don't print IllegalDomain errors, which are common when we try
            -- to resolve a file path as a DNS name.
            DNSError ByteString
_ DNSError
DNS.IllegalDomain -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            PingWarning
_ -> Handle -> FilePath -> IO ()
IO.hPutStrLn Handle
IO.stderr (PingWarning -> FilePath
formatPingWarning PingWarning
msg)

    -- resolved addresses
    rs <- DNS.makeResolvSeed DNS.defaultResolvConf
    resolvedAddresses <-
      DNS.withResolver rs $ \Resolver
resolver ->
        [[Address Resolved]] -> [Address Resolved]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Address Resolved]] -> [Address Resolved])
-> IO [[Address Resolved]] -> IO [Address Resolved]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Address (Unresolved SRVOrFilePathUnresolved)
 -> IO [Address Resolved])
-> [Address (Unresolved SRVOrFilePathUnresolved)]
-> IO [[Address Resolved]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved SRVOrFilePathUnresolved)
-> IO [Address Resolved]
forall (fpResolved :: ResolvedSRVOrFilePath).
Tracer IO PingWarning
-> Resolver
-> PingOpts
-> Address (Unresolved fpResolved)
-> IO [Address Resolved]
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts) [Address (Unresolved SRVOrFilePathUnresolved)]
addresses
    sockAddrs
      <- catMaybes
         <$> traverse
               (\case
                  addr :: Address Resolved
addr@(IP ip :: IP
ip@IPv4{} Port
port) ->
                    (AddrInfo -> (Address Resolved, AddrInfo))
-> Maybe AddrInfo -> Maybe (Address Resolved, AddrInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Address Resolved
addr,) (Maybe AddrInfo -> Maybe (Address Resolved, AddrInfo))
-> ([AddrInfo] -> Maybe AddrInfo)
-> [AddrInfo]
-> Maybe (Address Resolved, AddrInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
maybeHead ([AddrInfo] -> Maybe (Address Resolved, AddrInfo))
-> IO [AddrInfo] -> IO (Maybe (Address Resolved, AddrInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe FilePath -> Maybe FilePath -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo
-> Maybe FilePath -> Maybe FilePath -> IO (t AddrInfo)
Socket.getAddrInfo
                      (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
Socket.defaultHints { Socket.addrFamily = Socket.AF_INET })
                      (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip))
                      (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port))
                  addr :: Address Resolved
addr@(IP ip :: IP
ip@IPv6{} Port
port) ->
                    (AddrInfo -> (Address Resolved, AddrInfo))
-> Maybe AddrInfo -> Maybe (Address Resolved, AddrInfo)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Address Resolved
addr,) (Maybe AddrInfo -> Maybe (Address Resolved, AddrInfo))
-> ([AddrInfo] -> Maybe AddrInfo)
-> [AddrInfo]
-> Maybe (Address Resolved, AddrInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
maybeHead ([AddrInfo] -> Maybe (Address Resolved, AddrInfo))
-> IO [AddrInfo] -> IO (Maybe (Address Resolved, AddrInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe FilePath -> Maybe FilePath -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo
-> Maybe FilePath -> Maybe FilePath -> IO (t AddrInfo)
Socket.getAddrInfo
                      (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
Socket.defaultHints { Socket.addrFamily = Socket.AF_INET6 })
                      (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip))
                      (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port))
                  addr :: Address Resolved
addr@(FilePath FilePath
path) -> do
                    Maybe (Address Resolved, AddrInfo)
-> IO (Maybe (Address Resolved, AddrInfo))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Address Resolved, AddrInfo)
 -> IO (Maybe (Address Resolved, AddrInfo)))
-> Maybe (Address Resolved, AddrInfo)
-> IO (Maybe (Address Resolved, AddrInfo))
forall a b. (a -> b) -> a -> b
$ (Address Resolved, AddrInfo) -> Maybe (Address Resolved, AddrInfo)
forall a. a -> Maybe a
Just
                      ( Address Resolved
addr
                      , [AddrInfoFlag]
-> Family
-> SocketType
-> ProtocolNumber
-> SockAddr
-> Maybe FilePath
-> AddrInfo
Socket.AddrInfo
                         []
                         Family
Socket.AF_UNIX
                         SocketType
Socket.Stream
                         ProtocolNumber
Socket.defaultProtocol
                         (FilePath -> SockAddr
Socket.SockAddrUnix FilePath
path)
                         Maybe FilePath
forall a. Maybe a
Nothing
                      )
               )
               resolvedAddresses

    headerVar <- newHeaderVar
    signalVar <- newSignalVar (fst <$> sockAddrs)
    mapConcurrently_ (\case
                      -- ignore exceptions so other ping clients can
                      -- continue
                      addr :: (Address Resolved, AddrInfo)
addr@(IP {}, AddrInfo
_) ->
                        IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$
                        ProtocolFlavour NodeToNodeVersion NodeToNodeVersionData
-> Tracer IO (WithHost LogMsg)
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar (Address Resolved)
-> HeaderVar
-> (Address Resolved, AddrInfo)
-> IO ()
forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber) =>
ProtocolFlavour versionNumber versionData
-> Tracer IO (WithHost LogMsg)
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar (Address Resolved)
-> HeaderVar
-> (Address Resolved, AddrInfo)
-> IO ()
pingClient ProtocolFlavour NodeToNodeVersion NodeToNodeVersionData
NodeToNode Tracer IO (WithHost LogMsg)
stdout Tracer IO PingWarning
stderr PingOpts
opts SignalVar (Address Resolved)
signalVar HeaderVar
headerVar (Address Resolved, AddrInfo)
addr
                      addr :: (Address Resolved, AddrInfo)
addr@(FilePath {}, AddrInfo
_) ->
                        IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$
                        ProtocolFlavour NodeToClientVersion NodeToClientVersionData
-> Tracer IO (WithHost LogMsg)
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar (Address Resolved)
-> HeaderVar
-> (Address Resolved, AddrInfo)
-> IO ()
forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber) =>
ProtocolFlavour versionNumber versionData
-> Tracer IO (WithHost LogMsg)
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar (Address Resolved)
-> HeaderVar
-> (Address Resolved, AddrInfo)
-> IO ()
pingClient ProtocolFlavour NodeToClientVersion NodeToClientVersionData
NodeToClient Tracer IO (WithHost LogMsg)
stdout Tracer IO PingWarning
stderr PingOpts
opts SignalVar (Address Resolved)
signalVar HeaderVar
headerVar (Address Resolved, AddrInfo)
addr
                   ) sockAddrs

pingClient
  :: forall versionNumber versionData.
     ( Acceptable versionData
     , Queryable versionData
     , NFData versionData
     , Ord versionNumber
     , Show versionNumber
     , NFData versionNumber
     , ToJSON versionNumber
     )
  => ProtocolFlavour versionNumber versionData
  -> Tracer IO (WithHost LogMsg)
  -> Tracer IO PingWarning
  -> PingOpts
  -> SignalVar (Address Resolved)
  -> HeaderVar
  -> (Address Resolved, AddrInfo)
  -> IO ()
pingClient :: forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber) =>
ProtocolFlavour versionNumber versionData
-> Tracer IO (WithHost LogMsg)
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar (Address Resolved)
-> HeaderVar
-> (Address Resolved, AddrInfo)
-> IO ()
pingClient ProtocolFlavour versionNumber versionData
protocol Tracer IO (WithHost LogMsg)
stdout Tracer IO PingWarning
stderr opts :: PingOpts
opts@PingOpts{Bool
FilePath
Word32
NetworkMagic
PingMode
ColorMode
LogFormat
pingOptsCount :: PingOpts -> Word32
pingOptsMagic :: PingOpts -> NetworkMagic
pingOptsJson :: PingOpts -> LogFormat
pingOptsQuiet :: PingOpts -> Bool
pingOptsMode :: PingOpts -> PingMode
pingOptsSRVPrefix :: PingOpts -> FilePath
pingOptsColor :: PingOpts -> ColorMode
pingOptsCount :: Word32
pingOptsMagic :: NetworkMagic
pingOptsJson :: LogFormat
pingOptsQuiet :: Bool
pingOptsMode :: PingMode
pingOptsSRVPrefix :: FilePath
pingOptsColor :: ColorMode
..} SignalVar (Address Resolved)
signalVar HeaderVar
headerVar (Address Resolved
addr, AddrInfo
peer) =
  SignalVar (Address Resolved)
-> Address Resolved -> (Signal -> IO ()) -> IO ()
forall addr a.
Ord addr =>
SignalVar addr -> addr -> (Signal -> IO a) -> IO a
withSignal SignalVar (Address Resolved)
signalVar Address Resolved
addr ((Signal -> IO ()) -> IO ()) -> (Signal -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Signal
sig ->
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      (Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket (AddrInfo -> Family
Socket.addrFamily AddrInfo
peer) SocketType
Socket.Stream ProtocolNumber
Socket.defaultProtocol)
      Socket -> IO ()
Socket.close
      (\Socket
sd -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AddrInfo -> Family
Socket.addrFamily AddrInfo
peer Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
/= Family
Socket.AF_UNIX) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
sd SocketOption
Socket.NoDelay Int
1
          Socket -> SocketOption -> StructLinger -> IO ()
forall a. Storable a => Socket -> SocketOption -> a -> IO ()
Socket.setSockOpt Socket
sd SocketOption
Socket.Linger
            StructLinger
              { sl_onoff :: ProtocolNumber
sl_onoff  = ProtocolNumber
1
              , sl_linger :: ProtocolNumber
sl_linger = ProtocolNumber
0
              }
        Signal -> Socket -> IO ()
runPingClient Signal
sig Socket
sd
      )
  where
    runPingClient :: Signal -> Socket.Socket -> IO ()
    runPingClient :: Signal -> Socket -> IO ()
runPingClient Signal
sig Socket
sd = do
      let logMsg :: (ToText msg, ToJSON msg) => msg -> IO ()
          logMsg :: forall msg. (ToText msg, ToJSON msg) => msg -> IO ()
logMsg = PingOpts -> Address Resolved -> msg -> IO ()
forall msg.
(ToText msg, ToJSON msg) =>
PingOpts -> Address Resolved -> msg -> IO ()
logMsgWithPeer PingOpts
opts Address Resolved
addr
          stdout' :: Tracer IO LogMsg
stdout' = Address Resolved -> LogMsg -> WithHost LogMsg
forall a. Address Resolved -> a -> WithHost a
WithHost Address Resolved
addr (LogMsg -> WithHost LogMsg)
-> Tracer IO (WithHost LogMsg) -> Tracer IO LogMsg
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer IO (WithHost LogMsg)
stdout

      !t0_s <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

      handleJust (\SomeException
e -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of { Just SomeAsyncException {} -> Maybe SomeException
forall a. Maybe a
Nothing; Maybe SomeAsyncException
_ -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e })
                 (\SomeException
e  -> Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (SockAddr -> SomeException -> PingWarning
ConnectError (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
peer) SomeException
e)
                      IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
                 ) $
        Socket.connect sd (Socket.addrAddress peer)
      !t0_e <- getMonotonicTime

      logMsg $ NetworkRTT (toSample t0_e t0_s)

      connId <- ConnectionId <$> Socket.getSocketName sd
                             <*> Socket.getPeerName sd
      bearer <- getBearer makeSocketBearer sduTimeout sd Nothing

      -- Run handshake with RTT measurements
      -- NOTE: we pass all versions supported by `cardano-diffusion:api`
      r <- runHandshakeClientWithRTT
        @versionNumber @versionData @()
        bearer connId
        HandshakeArguments {
          haHandshakeTracer = nullTracer,
          haBearerTracer    = nullTracer,
          haHandshakeCodec  = case protocol of
            ProtocolFlavour versionNumber versionData
NodeToNode   -> Codec
  (Handshake versionNumber ChainSyncHeader)
  DeserialiseFailure
  IO
  ByteString
Codec
  (Handshake NodeToNodeVersion ChainSyncHeader)
  DeserialiseFailure
  IO
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToNodeVersion ChainSyncHeader)
  DeserialiseFailure
  m
  ByteString
NodeToNode.nodeToNodeHandshakeCodec
            ProtocolFlavour versionNumber versionData
NodeToClient -> Codec
  (Handshake versionNumber ChainSyncHeader)
  DeserialiseFailure
  IO
  ByteString
Codec
  (Handshake NodeToClientVersion ChainSyncHeader)
  DeserialiseFailure
  IO
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToClientVersion ChainSyncHeader)
  DeserialiseFailure
  m
  ByteString
NodeToClient.nodeToClientHandshakeCodec,
          haVersionDataCodec = case protocol of
            ProtocolFlavour versionNumber versionData
NodeToNode   -> VersionDataCodec versionNumber versionData
VersionDataCodec NodeToNodeVersion NodeToNodeVersionData
NodeToNode.nodeToNodeVersionDataCodec
            ProtocolFlavour versionNumber versionData
NodeToClient -> VersionDataCodec versionNumber versionData
VersionDataCodec NodeToClientVersion NodeToClientVersionData
NodeToClient.nodeToClientVersionDataCodec,
          haAcceptVersion = acceptableVersion,
          haQueryVersion  = queryVersion,
          haTimeLimits    = timeLimitsHandshake
        }
        (case protocol of
          ProtocolFlavour versionNumber versionData
NodeToNode ->
             (versionNumber -> Versions versionNumber versionData ())
-> [versionNumber] -> Versions versionNumber versionData ()
forall vNum (f :: * -> *) x extra r.
(Ord vNum, Foldable f, HasCallStack) =>
(x -> Versions vNum extra r) -> f x -> Versions vNum extra r
foldMapVersions
               (\versionNumber
versionNumber ->
                 versionNumber
-> versionData
-> (versionData -> ())
-> Versions versionNumber versionData ()
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions
                   versionNumber
versionNumber
                   NodeToNodeVersionData {
                     networkMagic :: NetworkMagic
networkMagic  = NetworkMagic
pingOptsMagic,
                     diffusionMode :: DiffusionMode
diffusionMode = DiffusionMode
InitiatorOnlyDiffusionMode,
                     peerSharing :: PeerSharing
peerSharing   = PeerSharing
PeerSharingDisabled,
                     query :: Bool
query         = case PingMode
pingOptsMode of
                                        PingMode
QueryMode -> Bool
True
                                        PingMode
_         -> Bool
False,
                     perasSupport :: PerasSupport
perasSupport  = if versionNumber
versionNumber versionNumber -> versionNumber -> Bool
forall a. Ord a => a -> a -> Bool
>= versionNumber
NodeToNodeVersion
NodeToNodeV_16
                                     then PerasSupport
PerasSupported
                                     else PerasSupport
PerasUnsupported
                   }
                   (() -> versionData -> ()
forall a b. a -> b -> a
const ())
               )
               [versionNumber
forall a. Bounded a => a
minBound..versionNumber
forall a. Bounded a => a
maxBound]

          ProtocolFlavour versionNumber versionData
NodeToClient ->
             (versionNumber -> Versions versionNumber versionData ())
-> [versionNumber] -> Versions versionNumber versionData ()
forall vNum (f :: * -> *) x extra r.
(Ord vNum, Foldable f, HasCallStack) =>
(x -> Versions vNum extra r) -> f x -> Versions vNum extra r
foldMapVersions
               (\versionNumber
versionNumber ->
                 versionNumber
-> versionData
-> (versionData -> ())
-> Versions versionNumber versionData ()
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions
                   versionNumber
versionNumber
                   NodeToClientVersionData {
                     networkMagic :: NetworkMagic
networkMagic = NetworkMagic
pingOptsMagic,
                     query :: Bool
query        = case PingMode
pingOptsMode of
                                      PingMode
QueryMode -> Bool
True
                                      PingMode
_         -> Bool
False
                   }
                   (() -> versionData -> ()
forall a b. a -> b -> a
const ())
               )
               [versionNumber
forall a. Bounded a => a
minBound..versionNumber
forall a. Bounded a => a
maxBound]
        )
      case r of
        Left ProtocolLimitFailure
err -> do
          PingClientError -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ProtocolLimitFailure -> PingClientError
PingClientProtocolLimitFailure ProtocolLimitFailure
err)
        Right (Left HandshakeProtocolError versionNumber
err', DiffTime
rtt) -> do
          HandshakeRTT -> IO ()
forall msg. (ToText msg, ToJSON msg) => msg -> IO ()
logMsg (DiffTime -> HandshakeRTT
HandshakeRTT DiffTime
rtt)
          PingClientError -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HandshakeProtocolError versionNumber
-> Address Resolved -> PingClientError
forall versionNumber.
Show versionNumber =>
HandshakeProtocolError versionNumber
-> Address Resolved -> PingClientError
PingClientHandshakeProtocolError HandshakeProtocolError versionNumber
err' Address Resolved
addr)
        Right (Right HandshakeResult () versionNumber versionData
r', DiffTime
rtt) -> do
          HandshakeRTT -> IO ()
forall msg. (ToText msg, ToJSON msg) => msg -> IO ()
logMsg (DiffTime -> HandshakeRTT
HandshakeRTT DiffTime
rtt)
          case HandshakeResult () versionNumber versionData
r' of
            HandshakeQueryResult Map versionNumber (Either Text versionData)
versions -> do
              Signal -> IO ()
signalReadiness Signal
sig
              Signal -> IO ()
awaitReadiness Signal
sig
              -- print query results if it was supported by the remote side
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PingMode
pingOptsMode PingMode -> PingMode -> Bool
forall a. Eq a => a -> a -> Bool
== PingMode
QueryMode) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Map versionNumber ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Map versionNumber ()) -> IO ())
-> IO (Map versionNumber ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                (versionNumber -> Either Text versionData -> IO ())
-> Map versionNumber (Either Text versionData)
-> IO (Map versionNumber ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey
                  (\versionNumber
version Either Text versionData
versionData ->
                    Tracer IO LogMsg -> LogMsg -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO LogMsg
stdout' (LogMsg -> IO ()) -> LogMsg -> IO ()
forall a b. (a -> b) -> a -> b
$
                      case ProtocolFlavour versionNumber versionData
protocol of
                        ProtocolFlavour versionNumber versionData
NodeToClient ->
                          NodeToClientVersion
-> Either Text NodeToClientVersionData -> LogMsg
LogNodeToClientVersionData versionNumber
NodeToClientVersion
version Either Text versionData
Either Text NodeToClientVersionData
versionData
                        ProtocolFlavour versionNumber versionData
NodeToNode ->
                          NodeToNodeVersion -> Either Text NodeToNodeVersionData -> LogMsg
LogNodeToNodeVersionData versionNumber
NodeToNodeVersion
version Either Text versionData
Either Text NodeToNodeVersionData
versionData
                  )
                  Map versionNumber (Either Text versionData)
versions
            HandshakeNegotiationResult ()
_ versionNumber
version versionData
_versionData -> do
              -- show negotiated version
              NegotiatedVersion versionNumber -> IO ()
forall msg. (ToText msg, ToJSON msg) => msg -> IO ()
logMsg (NegotiatedVersion versionNumber -> IO ())
-> NegotiatedVersion versionNumber -> IO ()
forall a b. (a -> b) -> a -> b
$ versionNumber -> NegotiatedVersion versionNumber
forall versionNumber.
versionNumber -> NegotiatedVersion versionNumber
NegotiatedVersion versionNumber
version
              case (ProtocolFlavour versionNumber versionData
protocol, PingMode
pingOptsMode) of
                (ProtocolFlavour versionNumber versionData
_, PingMode
QueryMode) ->
                  -- in `QueryMode` we didn't negotiated the connection, so we
                  -- cannot run any mini-protocol.
                  () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

                (ProtocolFlavour versionNumber versionData
_, PingMode
TipMode) -> do
                  --
                  -- run chain sync to get the tip
                  --
                  stdGen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
initStdGen
                  mx <- Mx.new
                          Mx.nullTracers
                          [MiniProtocolInfo {
                            miniProtocolNum        = case protocol of
                                                       ProtocolFlavour versionNumber versionData
NodeToNode -> MiniProtocolNum
NodeToNode.chainSyncMiniProtocolNum
                                                       ProtocolFlavour versionNumber versionData
NodeToClient -> MiniProtocolNum
NodeToClient.localChainSyncMiniProtocolNum,
                            miniProtocolDir        = Mx.InitiatorDirectionOnly,
                            miniProtocolLimits     = case protocol of
                                                       ProtocolFlavour versionNumber versionData
NodeToNode -> MiniProtocolParameters -> MiniProtocolLimits
NodeToNode.chainSyncProtocolLimits MiniProtocolParameters
NodeToNode.defaultMiniProtocolParameters
                                                       ProtocolFlavour versionNumber versionData
NodeToClient -> MiniProtocolLimits
NodeToClient.maximumMiniProtocolLimits,
                            miniProtocolCapability = Nothing
                          }]
                  withAsync (Mx.run mx bearer) $ \Async IO ()
_ ->
                    (Mux 'InitiatorMode IO
-> MiniProtocolNum
-> MiniProtocolDirection 'InitiatorMode
-> StartOnDemandOrEagerly
-> (ByteChannel IO -> IO ((), Maybe ByteString))
-> IO (STM IO (Either SomeException ()))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow m,
 MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mx.runMiniProtocol Mux 'InitiatorMode IO
mx
                      (case ProtocolFlavour versionNumber versionData
protocol of
                         ProtocolFlavour versionNumber versionData
NodeToNode -> MiniProtocolNum
NodeToNode.chainSyncMiniProtocolNum
                         ProtocolFlavour versionNumber versionData
NodeToClient -> MiniProtocolNum
NodeToClient.localChainSyncMiniProtocolNum
                      )
                      MiniProtocolDirection 'InitiatorMode
Mx.InitiatorDirectionOnly
                      StartOnDemandOrEagerly
Mx.StartEagerly
                      (\ByteChannel IO
channel ->
                        Tracer
  IO
  (TraceSendRecv
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip))
-> StdGen
-> Codec
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
     DeserialiseFailure
     IO
     ByteString
-> ProtocolSizeLimits
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip) ByteString
-> ProtocolTimeLimitsWithRnd
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
-> ByteChannel IO
-> Peer
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
     'AsClient
     'NonPipelined
     'StIdle
     IO
     ()
-> IO ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadThrow (STM m), MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure, HasCallStack) =>
Tracer m (TraceSendRecv ps)
-> StdGen
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimitsWithRnd ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimitsRnd
                          Tracer
  IO
  (TraceSendRecv
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
                          StdGen
stdGen
                          ((ChainSyncHeader -> Encoding)
-> (forall s. Decoder s ChainSyncHeader)
-> (ChainSyncHeader -> Encoding)
-> (forall s. Decoder s ChainSyncHeader)
-> (ChainSyncTip -> Encoding)
-> (forall s. Decoder s ChainSyncTip)
-> Codec
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
     DeserialiseFailure
     IO
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
ChainSync.codecChainSync ChainSyncHeader -> Encoding
CBOR.encodeTerm Decoder s ChainSyncHeader
forall s. Decoder s ChainSyncHeader
CBOR.decodeTerm
                                                    ChainSyncHeader -> Encoding
CBOR.encodeTerm Decoder s ChainSyncHeader
forall s. Decoder s ChainSyncHeader
CBOR.decodeTerm
                                                    ((HeaderHash ChainSyncBlock -> Encoding) -> ChainSyncTip -> Encoding
forall {k} (blk :: k).
(HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip ByteString -> Encoding
HeaderHash ChainSyncBlock -> Encoding
forall a. Serialise a => a -> Encoding
Serialise.encode)
                                                    ((forall s. Decoder s (HeaderHash ChainSyncBlock))
-> forall s. Decoder s ChainSyncTip
forall {k} (blk :: k).
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip Decoder s ByteString
Decoder s (HeaderHash ChainSyncBlock)
forall s. Decoder s ByteString
forall s. Decoder s (HeaderHash ChainSyncBlock)
forall a s. Serialise a => Decoder s a
Serialise.decode))
                          ((ByteString -> Port)
-> ProtocolSizeLimits
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip) ByteString
forall bytes header point tip.
(bytes -> Port)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
ChainSync.byteLimitsChainSync (Int64 -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Port) -> (ByteString -> Int64) -> ByteString -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length))
                          (ChainSyncIdleTimeout
-> PeerTrustable
-> ProtocolTimeLimitsWithRnd
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
forall header point tip.
ChainSyncIdleTimeout
-> PeerTrustable
-> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
ChainSync.timeLimitsChainSync ChainSyncIdleTimeout
defaultChainSyncIdleTimeout PeerTrustable
IsNotTrustable)
                          ByteChannel IO
channel
                          (ChainSyncClient ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
-> Peer
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
     'AsClient
     'NonPipelined
     'StIdle
     IO
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Client (ChainSync header point tip) 'NonPipelined 'StIdle m a
ChainSync.chainSyncClientPeer (ChainSyncClient ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
 -> Peer
      (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
      'AsClient
      'NonPipelined
      'StIdle
      IO
      ())
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
-> Peer
     (ChainSync ChainSyncHeader ChainSyncHeader ChainSyncTip)
     'AsClient
     'NonPipelined
     'StIdle
     IO
     ()
forall a b. (a -> b) -> a -> b
$ PingOpts
-> Signal
-> HeaderVar
-> Tracer IO LogMsg
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
chainSyncClient PingOpts
opts Signal
sig HeaderVar
headerVar Tracer IO LogMsg
stdout'))
                        IO (STM (Either SomeException ()))
-> (STM (Either SomeException ()) -> 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
>>= IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> (STM (Either SomeException ()) -> IO (Either SomeException ()))
-> STM (Either SomeException ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either SomeException ()) -> IO (Either SomeException ())
STM IO (Either SomeException ()) -> IO (Either SomeException ())
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically
                    )
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Mux 'InitiatorMode IO -> IO ()
forall (m :: * -> *) (mode :: Mode).
MonadSTM m =>
Mux mode m -> m ()
Mx.stop Mux 'InitiatorMode IO
mx
                  threadDelay idleTimeout

                (ProtocolFlavour versionNumber versionData
NodeToNode, PingMode
PingMode) -> do
                  --
                  -- run keepalive client to get RTT samples
                  --
                  mx <- Tracers IO
-> [MiniProtocolInfo 'InitiatorMode] -> IO (Mux 'InitiatorMode IO)
forall (mode :: Mode) (m :: * -> *).
MonadLabelledSTM m =>
Tracers m -> [MiniProtocolInfo mode] -> m (Mux mode m)
Mx.new
                          Tracers IO
forall (m :: * -> *) (f :: * -> *). Monad m => Tracers' m f
Mx.nullTracers
                          [MiniProtocolInfo {
                            miniProtocolNum :: MiniProtocolNum
miniProtocolNum        = MiniProtocolNum
NodeToNode.keepAliveMiniProtocolNum,
                            miniProtocolDir :: MiniProtocolDirection 'InitiatorMode
miniProtocolDir        = MiniProtocolDirection 'InitiatorMode
Mx.InitiatorDirectionOnly,
                            miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits     = MiniProtocolParameters -> MiniProtocolLimits
NodeToNode.keepAliveProtocolLimits MiniProtocolParameters
NodeToNode.defaultMiniProtocolParameters,
                            miniProtocolCapability :: Maybe Int
miniProtocolCapability = Maybe Int
forall a. Maybe a
Nothing
                          }]
                  withAsync (Mx.run mx bearer) $ \Async IO ()
_ ->
                    (Mux 'InitiatorMode IO
-> MiniProtocolNum
-> MiniProtocolDirection 'InitiatorMode
-> StartOnDemandOrEagerly
-> (ByteChannel IO -> IO ((), Maybe ByteString))
-> IO (STM IO (Either SomeException ()))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow m,
 MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mx.runMiniProtocol Mux 'InitiatorMode IO
mx
                      MiniProtocolNum
NodeToNode.keepAliveMiniProtocolNum
                      MiniProtocolDirection 'InitiatorMode
Mx.InitiatorDirectionOnly
                      StartOnDemandOrEagerly
Mx.StartEagerly
                      (\ByteChannel IO
channel ->
                        Tracer IO (TraceSendRecv KeepAlive)
-> Codec KeepAlive DeserialiseFailure IO ByteString
-> ProtocolSizeLimits KeepAlive ByteString
-> ProtocolTimeLimits KeepAlive
-> ByteChannel IO
-> Peer KeepAlive 'AsClient 'NonPipelined 'StClient IO ()
-> IO ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadThrow (STM m), MonadTimer m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeerWithLimits
                          Tracer IO (TraceSendRecv KeepAlive)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
                          Codec KeepAlive DeserialiseFailure IO ByteString
forall (m :: * -> *).
MonadST m =>
Codec KeepAlive DeserialiseFailure m ByteString
KeepAlive.codecKeepAlive_v2
                          ((ByteString -> Port) -> ProtocolSizeLimits KeepAlive ByteString
forall bytes. (bytes -> Port) -> ProtocolSizeLimits KeepAlive bytes
KeepAlive.byteLimitsKeepAlive (Int64 -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Port) -> (ByteString -> Int64) -> ByteString -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length))
                          ProtocolTimeLimits KeepAlive
KeepAlive.timeLimitsKeepAlive
                          ByteChannel IO
channel
                          (KeepAliveClient IO ()
-> Peer KeepAlive 'AsClient 'NonPipelined 'StClient IO ()
forall (m :: * -> *) a.
MonadThrow m =>
KeepAliveClient m a -> Client KeepAlive 'NonPipelined 'StClient m a
KeepAlive.keepAliveClientPeer
                            (KeepAliveClient IO ()
 -> Peer KeepAlive 'AsClient 'NonPipelined 'StClient IO ())
-> KeepAliveClient IO ()
-> Peer KeepAlive 'AsClient 'NonPipelined 'StClient IO ()
forall a b. (a -> b) -> a -> b
$ PingOpts
-> Signal
-> HeaderVar
-> Tracer IO LogMsg
-> TDigest 5
-> KeepAliveClient IO ()
keepAliveClient
                                PingOpts
opts
                                Signal
sig
                                HeaderVar
headerVar
                                Tracer IO LogMsg
stdout'
                                ([Double] -> TDigest 5
forall (f :: * -> *) (comp :: Nat).
(Foldable f, KnownNat comp) =>
f Double -> TDigest comp
TDigest.tdigest [])))
                        IO (STM (Either SomeException ()))
-> (STM (Either SomeException ()) -> 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
>>= IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> (STM (Either SomeException ()) -> IO (Either SomeException ()))
-> STM (Either SomeException ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Either SomeException ()) -> IO (Either SomeException ())
STM IO (Either SomeException ()) -> IO (Either SomeException ())
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically
                    )
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Mux 'InitiatorMode IO -> IO ()
forall (m :: * -> *) (mode :: Mode).
MonadSTM m =>
Mux mode m -> m ()
Mx.stop Mux 'InitiatorMode IO
mx
                  threadDelay idleTimeout

                (ProtocolFlavour versionNumber versionData
NodeToClient, PingMode
PingMode) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  --
                  -- ping mode over node-to-client protocol is not supported
                  --


toSample :: Time -> Time -> Double
toSample :: Time -> Time -> Double
toSample Time
end Time
start = DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (DiffTime -> Double) -> DiffTime -> Double
forall a b. (a -> b) -> a -> b
$ Time
end Time -> Time -> DiffTime
`diffTime` Time
start

format :: (ToText a, ToJSON a) => LogFormat -> a -> TL.Text
format :: forall a. (ToText a, ToJSON a) => LogFormat -> a -> Text
format LogFormat
AsJSON = Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText (Value -> Text) -> (a -> Value) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
format LogFormat
AsText = a -> Text
forall a. ToText a => a -> Text
toText

class ToText a where
  toText :: a -> TL.Text

data WithHost a = WithHost (Address Resolved) a

instance ToText a => ToText (WithHost a) where
  toText :: WithHost a -> Text
toText (WithHost Address Resolved
host a
a) =
    FilePath -> Text
TL.pack (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-47s" (Address Resolved -> FilePath
forall a. Show a => a -> FilePath
show Address Resolved
host FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", ")) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. ToText a => a -> Text
toText a
a

instance ToJSON a => ToJSON (WithHost a) where
  toJSON :: WithHost a -> Value
toJSON (WithHost Address Resolved
host a
a) =
    case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a of
      Aeson.Object Object
o ->
        Object -> Value
Aeson.Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"host" (FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON (FilePath -> Value) -> FilePath -> Value
forall a b. (a -> b) -> a -> b
$ Address Resolved -> FilePath
forall a. Show a => a -> FilePath
show Address Resolved
host) Object
o)

      Value
x -> [Pair] -> Value
object [ Key
"host" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Address Resolved -> FilePath
forall a. Show a => a -> FilePath
show Address Resolved
host, Key
"data" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
x ]

newtype NegotiatedVersion versionNumber = NegotiatedVersion versionNumber

instance Show versionNumber
      => ToText (NegotiatedVersion versionNumber) where
  toText :: NegotiatedVersion versionNumber -> Text
toText (NegotiatedVersion versionNumber
v) = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"negotiated versions: %s" (versionNumber -> FilePath
forall a. Show a => a -> FilePath
show versionNumber
v)

instance ToJSON versionNumber
      => ToJSON (NegotiatedVersion versionNumber) where
  toJSON :: NegotiatedVersion versionNumber -> Value
toJSON (NegotiatedVersion versionNumber
v) = [Pair] -> Value
object [Key
"negotiated_versions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= versionNumber -> Value
forall a. ToJSON a => a -> Value
toJSON versionNumber
v]


newtype QueriedVersions versionNumber = QueriedVersions [versionNumber]

instance Show versionNumber
      => ToText (QueriedVersions versionNumber) where
  toText :: QueriedVersions versionNumber -> Text
toText (QueriedVersions [versionNumber]
vs) =
    FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Queried versions: %s" ([FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ versionNumber -> FilePath
forall a. Show a => a -> FilePath
show (versionNumber -> FilePath) -> [versionNumber] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [versionNumber]
vs)

instance ToJSON versionNumber
      => ToJSON (QueriedVersions versionNumber) where
  toJSON :: QueriedVersions versionNumber -> Value
toJSON (QueriedVersions [versionNumber]
vs) =
    [Pair] -> Value
object [Key
"queried_versions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [versionNumber] -> Value
forall a. ToJSON a => a -> Value
toJSON [versionNumber]
vs]


newtype NetworkRTT = NetworkRTT Double

instance ToText NetworkRTT where
  toText :: NetworkRTT -> Text
toText (NetworkRTT Double
rtt) =
    FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"network rtt: %.3fs" Double
rtt

instance ToJSON NetworkRTT where
  toJSON :: NetworkRTT -> Value
toJSON (NetworkRTT Double
rtt) =
    [Pair] -> Value
object [Key
"network_rtt" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double -> Value
forall a. ToJSON a => a -> Value
toJSON Double
rtt]


newtype HandshakeRTT = HandshakeRTT DiffTime

instance ToText HandshakeRTT where
  toText :: HandshakeRTT -> Text
toText (HandshakeRTT DiffTime
diff) =
    FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"handshake rtt: %.3fs" (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
diff :: Double)

instance ToJSON HandshakeRTT where
  toJSON :: HandshakeRTT -> Value
toJSON (HandshakeRTT DiffTime
diff) =
    [Pair] -> Value
object [Key
"handshake rtt" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Double -> Value
forall a. ToJSON a => a -> Value
toJSON ((Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
diff) :: Double)]


-- note: use `logMsg` defined above in terms of `logMsgWithPeer`
logMsgWithPeer :: (ToText msg, ToJSON msg)
               => PingOpts
               -> Address Resolved
               -> msg
               -> IO ()
logMsgWithPeer :: forall msg.
(ToText msg, ToJSON msg) =>
PingOpts -> Address Resolved -> msg -> IO ()
logMsgWithPeer PingOpts { Bool
pingOptsQuiet :: PingOpts -> Bool
pingOptsQuiet :: Bool
pingOptsQuiet, LogFormat
pingOptsJson :: PingOpts -> LogFormat
pingOptsJson :: LogFormat
pingOptsJson } Address Resolved
addr msg
msg =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pingOptsQuiet (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
TL.hPutStrLn Handle
IO.stdout (LogFormat -> WithHost msg -> Text
forall a. (ToText a, ToJSON a) => LogFormat -> a -> Text
format LogFormat
pingOptsJson (Address Resolved -> msg -> WithHost msg
forall a. Address Resolved -> a -> WithHost a
WithHost Address Resolved
addr msg
msg))


instance ShowProxy CBOR.Term where
  showProxy :: Proxy ChainSyncHeader -> FilePath
showProxy Proxy ChainSyncHeader
_ = FilePath
"CBOR.Term"

--
-- Utils
--

maybeHead :: [a] -> Maybe a
maybeHead :: forall a. [a] -> Maybe a
maybeHead []    = Maybe a
forall a. Maybe a
Nothing
maybeHead (a
a:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

splitWith :: Char -> String -> Maybe (String, String)
splitWith :: Char -> FilePath -> Maybe (FilePath, FilePath)
splitWith Char
c = FilePath -> FilePath -> Maybe (FilePath, FilePath)
go FilePath
""
    where
      go :: FilePath -> FilePath -> Maybe (FilePath, FilePath)
go FilePath
_ []
        = Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing
      go !FilePath
acc (Char
a:FilePath
as)
        | Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
        = (FilePath, FilePath) -> Maybe (FilePath, FilePath)
forall a. a -> Maybe a
Just (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
acc, FilePath
as)
      go !FilePath
acc (Char
a:FilePath
as)
        = FilePath -> FilePath -> Maybe (FilePath, FilePath)
go (Char
aChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
acc) FilePath
as


type SignalVar addr = StrictTVar IO (Map addr Bool)

data Signal = Signal {
    Signal -> IO ()
signalReadiness :: IO (),
    Signal -> STM IO Bool
getReadiness    :: STM IO Bool
  }

awaitReadiness :: Signal -> IO ()
awaitReadiness :: Signal -> IO ()
awaitReadiness Signal { STM IO Bool
getReadiness :: Signal -> STM IO Bool
getReadiness :: STM IO Bool
getReadiness } =
  STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM Bool
STM IO Bool
getReadiness STM Bool -> (Bool -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
Bool -> STM IO ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check)

signalAndGetReadiness :: Signal -> IO Bool
signalAndGetReadiness :: Signal -> IO Bool
signalAndGetReadiness Signal { IO ()
signalReadiness :: Signal -> IO ()
signalReadiness :: IO ()
signalReadiness, STM IO Bool
getReadiness :: Signal -> STM IO Bool
getReadiness :: STM IO Bool
getReadiness } = do
  IO ()
signalReadiness
  STM IO Bool -> IO Bool
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM IO Bool
getReadiness

newSignalVar :: Ord addr
             => [addr]
             -> IO (SignalVar addr)
newSignalVar :: forall addr. Ord addr => [addr] -> IO (SignalVar addr)
newSignalVar [addr]
addrs = Map addr Bool -> IO (StrictTVar IO (Map addr Bool))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ([(addr, Bool)] -> Map addr Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(addr
addr, Bool
False) | addr
addr <- [addr]
addrs])

withSignal :: Ord addr
           => SignalVar addr
           -> addr
           -> (Signal -> IO a)
           -> IO a
withSignal :: forall addr a.
Ord addr =>
SignalVar addr -> addr -> (Signal -> IO a) -> IO a
withSignal SignalVar addr
var addr
addr Signal -> IO a
k =
  let signalReadiness :: IO ()
      signalReadiness :: IO ()
signalReadiness = STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalVar addr -> (Map addr Bool -> Map addr Bool) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar SignalVar addr
var (addr -> Bool -> Map addr Bool -> Map addr Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert addr
addr Bool
True)

      getReadiness :: STM IO Bool
      getReadiness :: STM IO Bool
getReadiness = All -> Bool
getAll (All -> Bool) -> (Map addr Bool -> All) -> Map addr Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> All) -> Map addr Bool -> All
forall m a. Monoid m => (a -> m) -> Map addr a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Bool -> All
All (Map addr Bool -> Bool) -> STM (Map addr Bool) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignalVar addr -> STM IO (Map addr Bool)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar SignalVar addr
var
  in Signal -> IO a
k Signal { IO ()
signalReadiness :: IO ()
signalReadiness :: IO ()
signalReadiness, STM IO Bool
getReadiness :: STM IO Bool
getReadiness :: STM IO Bool
getReadiness }
     IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException`
     STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (SignalVar addr -> (Map addr Bool -> Map addr Bool) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar SignalVar addr
var (addr -> Bool -> Map addr Bool -> Map addr Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert addr
addr Bool
True))


data HeaderState = NotPrinted | Printing | Printed
type HeaderVar = StrictTVar IO HeaderState

newHeaderVar :: IO HeaderVar
newHeaderVar :: IO HeaderVar
newHeaderVar = HeaderState -> IO HeaderVar
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO HeaderState
NotPrinted

printHeader :: PingOpts
            -> HeaderVar
            -> String
            -> IO ()
printHeader :: PingOpts -> HeaderVar -> FilePath -> IO ()
printHeader PingOpts { LogFormat
pingOptsJson :: PingOpts -> LogFormat
pingOptsJson :: LogFormat
pingOptsJson, ColorMode
pingOptsColor :: PingOpts -> ColorMode
pingOptsColor :: ColorMode
pingOptsColor } HeaderVar
headerVar FilePath
hdr = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogFormat
pingOptsJson LogFormat -> LogFormat -> Bool
forall a. Eq a => a -> a -> Bool
== LogFormat
AsText) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    st <- STM IO HeaderState -> IO HeaderState
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO HeaderState -> IO HeaderState)
-> STM IO HeaderState -> IO HeaderState
forall a b. (a -> b) -> a -> b
$ do
      st <- HeaderVar -> STM IO HeaderState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar HeaderVar
headerVar
      case st of
        HeaderState
NotPrinted -> HeaderVar -> HeaderState -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar HeaderVar
headerVar HeaderState
Printing
                   STM () -> STM HeaderState -> STM HeaderState
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HeaderState -> STM HeaderState
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeaderState
st
        HeaderState
Printing   -> STM HeaderState
STM IO HeaderState
forall a. STM IO a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
        HeaderState
Printed    -> HeaderState -> STM HeaderState
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderState
st
    case st of
      HeaderState
NotPrinted -> do
        useColor <- case ColorMode
pingOptsColor of
          ColorMode
ColorAlways -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          ColorMode
ColorNever  -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          ColorMode
ColorAuto   -> Handle -> IO Bool
IO.hIsTerminalDevice Handle
IO.stdout
        IO.putStrLn (if useColor then "\ESC[1m" ++ hdr ++ "\ESC[0m" else hdr)
        atomically (writeTVar headerVar Printed)
      HeaderState
Printing   -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"impossible"
      HeaderState
Printed    -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()