{-# 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
  ( -- * API
    pingClients
  , pingClients'
  , pingClient
    -- * Options and arguments
  , PingOpts (..)
  , Stage (..)
  , ResolvedSRVOrFilePath (..)
  , Address (IP)
  , mkAddress
  , cmdlineParser
  , PingMode (..)
  , AcceptFilePath (..)
  , LogFormat (..)
  , ColorMode (..)
    -- * Log messages
  , PingWarning (..)
  , PingException (..)
  , WithHost (..)
  , LogMsg (..)
  , StatPoint (..)
  , mkStdOutTracer
  , mkStdErrTracer
  , mkHeaderTracer
    -- ** Formatting log messages
  , format
  , ToText (..)
    -- * Exceptions
  , PingClientException (..)
    -- * Cardano main-net configuration
  , mainnetMagic
    -- * Re-exports
  , 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.Read qualified as CBOR
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.Either (lefts)
import Data.Foldable (traverse_)
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, SockAddr, StructLinger (..))
import Network.Socket qualified as Socket
import Options.Applicative
import Options.Applicative.Help.Pretty qualified as Pretty
import System.Directory (doesFileExist)
import System.Exit qualified as IO
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 -> ShowS
[LogFormat] -> ShowS
LogFormat -> FilePath
(Int -> LogFormat -> ShowS)
-> (LogFormat -> FilePath)
-> ([LogFormat] -> ShowS)
-> Show LogFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogFormat -> ShowS
showsPrec :: Int -> LogFormat -> ShowS
$cshow :: LogFormat -> FilePath
show :: LogFormat -> FilePath
$cshowList :: [LogFormat] -> ShowS
showList :: [LogFormat] -> ShowS
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 -> ShowS
[ColorMode] -> ShowS
ColorMode -> FilePath
(Int -> ColorMode -> ShowS)
-> (ColorMode -> FilePath)
-> ([ColorMode] -> ShowS)
-> Show ColorMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColorMode -> ShowS
showsPrec :: Int -> ColorMode -> ShowS
$cshow :: ColorMode -> FilePath
show :: ColorMode -> FilePath
$cshowList :: [ColorMode] -> ShowS
showList :: [ColorMode] -> ShowS
Show)


data PingMode =
    TipMode
    -- ^ query 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 -> ShowS
[PingMode] -> ShowS
PingMode -> FilePath
(Int -> PingMode -> ShowS)
-> (PingMode -> FilePath) -> ([PingMode] -> ShowS) -> Show PingMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PingMode -> ShowS
showsPrec :: Int -> PingMode -> ShowS
$cshow :: PingMode -> FilePath
show :: PingMode -> FilePath
$cshowList :: [PingMode] -> ShowS
showList :: [PingMode] -> ShowS
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

deriving instance Show (Address resolved)


-- | A smart constructor for `Address` type.
--
mkAddress :: String -> Address (Unresolved SRVOrFilePathUnresolved)
mkAddress :: FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
mkAddress FilePath
s | Bool
illegalDomain = FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
FilePathOrDomain FilePath
s
            | Bool
otherwise     = FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
SRV FilePath
s
  where
    -- A basic test to decide between `FilePathOrDomain` or `SRV`.  The `dns`
    -- library has a slightly more advanced version and returns `IllegalDomain`
    -- error.
    illegalDomain :: Bool
    illegalDomain :: Bool
illegalDomain
      | Char
':' Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` FilePath
s    = Bool
True
      | Char
'/' Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` FilePath
s    = Bool
True
      | Char
'.' Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.notElem` FilePath
s = Bool
True
      | Bool
otherwise            = Bool
False


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 -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ IP -> FilePath
forall a. Show a => a -> FilePath
show IP
ip FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"]:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port

ppAddress :: Address stage -> String
ppAddress :: forall (resolved :: Stage). Address resolved -> FilePath
ppAddress (IP IP
ip Port
port)            = IP -> Port -> FilePath
showIPWithPort IP
ip Port
port
ppAddress (FilePath FilePath
path)         = FilePath
path
ppAddress (FilePathOrDomain FilePath
path) = FilePath
path
ppAddress (Domain Domain
domain Port
port)    = Domain -> FilePath
BS.Char.unpack Domain
domain FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
port
ppAddress (SRV FilePath
domain)            = FilePath
domain

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

data SomeAddress where
    SomeAddress :: forall (stage :: Stage).
                   Address stage
                -> SomeAddress

instance Show SomeAddress where
  show :: SomeAddress -> FilePath
show (SomeAddress Address stage
address) = Address stage -> FilePath
forall a. Show a => a -> FilePath
show Address stage
address

ppSomeAddress :: SomeAddress -> String
ppSomeAddress :: SomeAddress -> FilePath
ppSomeAddress (SomeAddress Address stage
addr) = Address stage -> FilePath
forall (resolved :: Stage). Address resolved -> FilePath
ppAddress Address stage
addr

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
  }

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
$ Address (Unresolved SRVOrFilePathUnresolved)
-> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved))
forall a b. b -> Either a b
Right (Address (Unresolved SRVOrFilePathUnresolved)
 -> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved)))
-> (FilePath -> Address (Unresolved SRVOrFilePathUnresolved))
-> FilePath
-> Either FilePath (Address (Unresolved SRVOrFilePathUnresolved))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
mkAddress

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 -> ShowS
[LogMsg] -> ShowS
LogMsg -> FilePath
(Int -> LogMsg -> ShowS)
-> (LogMsg -> FilePath) -> ([LogMsg] -> ShowS) -> Show LogMsg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogMsg -> ShowS
showsPrec :: Int -> LogMsg -> ShowS
$cshow :: LogMsg -> FilePath
show :: LogMsg -> FilePath
$cshowList :: [LogMsg] -> ShowS
showList :: [LogMsg] -> ShowS
Show



data LogInfoMsg = LogNetworkRTT NetworkRTT
                | LogHandshakeRTT HandshakeRTT
                | forall versionNumber.
                  (Show versionNumber, ToText versionNumber, ToJSON versionNumber)
                  => LogNegotiatedVersion (NegotiatedVersion versionNumber)

deriving instance Show LogInfoMsg


data AddressResolutionError =
     FilePathDoesNotExistError FilePath
   | NoPortNumberError SomeAddress
   | DNSError SomeAddress DNS.DNSError
  deriving Int -> AddressResolutionError -> ShowS
[AddressResolutionError] -> ShowS
AddressResolutionError -> FilePath
(Int -> AddressResolutionError -> ShowS)
-> (AddressResolutionError -> FilePath)
-> ([AddressResolutionError] -> ShowS)
-> Show AddressResolutionError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddressResolutionError -> ShowS
showsPrec :: Int -> AddressResolutionError -> ShowS
$cshow :: AddressResolutionError -> FilePath
show :: AddressResolutionError -> FilePath
$cshowList :: [AddressResolutionError] -> ShowS
showList :: [AddressResolutionError] -> ShowS
Show

instance Exception AddressResolutionError where
  displayException :: AddressResolutionError -> FilePath
displayException (FilePathDoesNotExistError FilePath
path)
    = FilePath
"file path " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
path FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" does not exist"
  displayException (NoPortNumberError SomeAddress
addr)
    = FilePath
"missing port number for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeAddress -> FilePath
ppSomeAddress SomeAddress
addr
  displayException (DNSError SomeAddress
addr DNSError
err)
    = SomeAddress -> FilePath
ppSomeAddress SomeAddress
addr FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ DNSError -> FilePath
forall e. Exception e => e -> FilePath
displayException DNSError
err

-- | Log messages to stderr.
--
data PingWarning = AddressResolutionError AddressResolutionError
                 | DNSResolution DNS.Domain [IP] Word
                 | Error SomeException
                 | ConnectError SockAddr SomeException


instance ToText PingWarning where
  toText :: PingWarning -> Text
toText PingWarning
msg = PingWarning -> Text
severity PingWarning
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PingWarning -> Text
fn PingWarning
msg
    where
      fn :: PingWarning -> Text
fn (AddressResolutionError AddressResolutionError
err)
        = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ AddressResolutionError -> FilePath
forall e. Exception e => e -> FilePath
displayException AddressResolutionError
err
      fn (DNSResolution Domain
domain [IP]
ips Port
port)
        = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Domain -> FilePath
BS.Char.unpack Domain
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 (Error SomeException
err)
        = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
err
      fn (ConnectError SockAddr
sockAddr SomeException
err)
        = FilePath -> Text
TL.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-47s %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
sockAddr) (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
err)

      severity :: PingWarning -> TL.Text
      severity :: PingWarning -> Text
severity = \case
          AddressResolutionError{} -> Text
warning
          DNSResolution{}          -> Text
forall a. Monoid a => a
mempty
          Error{}                  -> Text
warning
          ConnectError{}           -> Text
warning
        where
          warning :: Text
warning = FilePath -> Text
TL.pack 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 ToText LogInfoMsg where
  toText :: LogInfoMsg -> Text
toText (LogNetworkRTT NetworkRTT
rtt)      = NetworkRTT -> Text
forall a. ToText a => a -> Text
toText NetworkRTT
rtt
  toText (LogHandshakeRTT HandshakeRTT
rtt)    = HandshakeRTT -> Text
forall a. ToText a => a -> Text
toText HandshakeRTT
rtt
  toText (LogNegotiatedVersion NegotiatedVersion versionNumber
v) = NegotiatedVersion versionNumber -> Text
forall a. ToText a => a -> Text
toText NegotiatedVersion versionNumber
v

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 ]

instance ToJSON LogInfoMsg where
  toJSON :: LogInfoMsg -> Value
toJSON (LogNetworkRTT NetworkRTT
rtt)      = NetworkRTT -> Value
forall a. ToJSON a => a -> Value
toJSON NetworkRTT
rtt
  toJSON (LogHandshakeRTT HandshakeRTT
rtt)    = HandshakeRTT -> Value
forall a. ToJSON a => a -> Value
toJSON HandshakeRTT
rtt
  toJSON (LogNegotiatedVersion NegotiatedVersion versionNumber
v) = NegotiatedVersion versionNumber -> Value
forall a. ToJSON a => a -> Value
toJSON NegotiatedVersion versionNumber
v


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

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

hexStr :: ByteString -> String
hexStr :: Domain -> FilePath
hexStr = (Word8 -> ShowS) -> FilePath -> Domain -> FilePath
forall a. (Word8 -> a -> a) -> a -> Domain -> a
BS.foldr (\Word8
b -> FilePath -> ShowS
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
Domain
BlockNo
SlotNo
ptRtt :: PingTip -> Double
ptHash :: PingTip -> Domain
ptBlockNo :: PingTip -> BlockNo
ptSlotNo :: PingTip -> SlotNo
ptRtt :: Double
ptHash :: Domain
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
           (Domain -> FilePath
hexStr Domain
ptHash)
           (BlockNo -> Word64
unBlockNo BlockNo
ptBlockNo)
           (SlotNo -> Word64
unSlotNo SlotNo
ptSlotNo)

instance ToJSON PingTip where
  toJSON :: PingTip -> Value
toJSON PingTip{Double
Domain
BlockNo
SlotNo
ptRtt :: PingTip -> Double
ptHash :: PingTip -> Domain
ptBlockNo :: PingTip -> BlockNo
ptSlotNo :: PingTip -> SlotNo
ptRtt :: Double
ptHash :: Domain
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
.= Domain -> FilePath
hexStr Domain
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
",")
      Word16
spCookie Double
spSample Double
spMedian Double
spP90 Double
spMean Double
spMin Double
spMax Double
spStd


data Header = PingHeader | TipHeader

instance ToText Header where
  toText :: Header -> Text
toText Header
PingHeader = FilePath -> Text
TL.pack
                    (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> ShowS
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)
  toText Header
TipHeader = FilePath -> Text
TL.pack
                   (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ShowS
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 Header where
  toJSON :: Header -> Value
toJSON Header
_ = Value
Aeson.Null

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 PingClientException
  = ProtocolLimitException ProtocolLimitFailure SockAddr
  -- ^ protocol limit error

  | forall versionNumber.
    Show versionNumber
  => HandshakeException (HandshakeProtocolError versionNumber) SockAddr
  -- ^ handshake protocol error

  | IOException IOError SockAddr
  -- ^ IO errors

  | DecodingException CBOR.DeserialiseFailure SockAddr
  -- ^ cbor exceptions

  | MuxException Mx.Error SockAddr
  -- ^ mux exceptions

deriving instance Show PingClientException

instance Exception PingClientException where
  displayException :: PingClientException -> FilePath
displayException (ProtocolLimitException ProtocolLimitFailure
err SockAddr
addr) =
    FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s protocol limits error: %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
addr) (ProtocolLimitFailure -> FilePath
forall e. Exception e => e -> FilePath
displayException ProtocolLimitFailure
err)
  displayException (HandshakeException HandshakeProtocolError versionNumber
err SockAddr
addr) =
    FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s handshake error: %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
addr) (HandshakeProtocolError versionNumber -> FilePath
forall a. Show a => a -> FilePath
show HandshakeProtocolError versionNumber
err)
  displayException (IOException IOError
err SockAddr
addr) =
    FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s io error: %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
addr) (IOError -> FilePath
forall e. Exception e => e -> FilePath
displayException IOError
err)
  displayException (DecodingException DeserialiseFailure
err SockAddr
addr) =
    FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s decoding error: %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
addr) (DeserialiseFailure -> FilePath
forall e. Exception e => e -> FilePath
displayException DeserialiseFailure
err)
  displayException (MuxException Error
err SockAddr
addr) =
    FilePath -> FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s mux error: %s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
addr) (Error -> FilePath
forall e. Exception e => e -> FilePath
displayException Error
err)

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

data SomeProtocolFlavour where
    SomeProtocolFlavour :: forall versionNumber versionData.
                           ( Acceptable versionData
                           , Queryable versionData
                           , NFData versionData
                           , Ord versionNumber
                           , Show versionNumber
                           , NFData versionNumber
                           , ToJSON versionNumber
                           , ToText versionNumber
                           )
                        => ProtocolFlavour versionNumber versionData
                        -> SomeProtocolFlavour

--
-- 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
  :: Signal
  -> Tracer IO LogMsg
  -> Tracer IO Header
  -> ChainSyncClient ChainSyncHeader ChainSyncPoint ChainSyncTip IO ()
chainSyncClient :: Signal
-> Tracer IO LogMsg
-> Tracer IO Header
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
chainSyncClient sig :: Signal
sig@Signal { IO ()
signalReadiness :: IO ()
signalReadiness :: Signal -> IO ()
signalReadiness } Tracer IO LogMsg
stdout Tracer IO Header
headerTracer =
    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, Domain
forall a. Monoid a => a
mempty, BlockNo
0)
                   Tip SlotNo
slotNo HeaderHash ChainSyncBlock
hash BlockNo
blockNo -> (SlotNo
slotNo, Domain
HeaderHash ChainSyncBlock
hash, BlockNo
blockNo)
                 pingTip = PingTip {
                   ptRtt :: Double
ptRtt  = Time -> Time -> Double
toSample Time
end Time
start,
                   Domain
ptHash :: Domain
ptHash :: Domain
ptHash,
                   BlockNo
ptBlockNo :: BlockNo
ptBlockNo :: BlockNo
ptBlockNo,
                   SlotNo
ptSlotNo :: SlotNo
ptSlotNo :: SlotNo
ptSlotNo
                 }
             awaitReadiness sig
             traceWith headerTracer TipHeader
             traceWith stdout (LogChainSyncTip pingTip)
             return $ ChainSync.SendMsgDone ()
       }


--
-- KeepAlive RTT sampling
--

keepAliveClient
  :: PingOpts
  -> Signal
  -> Tracer IO LogMsg
  -> Tracer IO Header
  -> TDigest 5
  -> KeepAliveClient IO ()
keepAliveClient :: PingOpts
-> Signal
-> Tracer IO LogMsg
-> Tracer IO Header
-> TDigest 5
-> KeepAliveClient IO ()
keepAliveClient PingOpts { Word32
pingOptsCount :: PingOpts -> Word32
pingOptsCount :: Word32
pingOptsCount } Signal
sig Tracer IO LogMsg
stdout Tracer IO Header
headerTracer 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
            traceWith headerTracer PingHeader
            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` has two modes of operations.  It can try to resolve an
-- `Address` to a `FilePath`, or not.  In the latter case the errors will be
-- more precise.  It is useful when validating an srv record / domain names / ip
-- addresses.
--
data AcceptFilePath = AddressMightBeAFilePath | AddressIsNotAFilePath


resolveAddress
  :: Tracer IO PingWarning
  -- ^ stderr
  -> DNS.Resolver
  -> PingOpts
  -> AcceptFilePath
  -- ^ if ``
  -- then we won't try to resolve an address as a `FilePath`.
  -> Address (Unresolved SRVOrFilePathUnresolved)
  -- ^ Either `FilePathOrDomain` or `SRV`, use `mkAddress` to
  -- construct the right one.
  -> IO ([Address Resolved], [AddressResolutionError])
resolveAddress :: Tracer IO PingWarning
-> Resolver
-> PingOpts
-> AcceptFilePath
-> Address (Unresolved SRVOrFilePathUnresolved)
-> IO ([Address Resolved], [AddressResolutionError])
resolveAddress
    Tracer IO PingWarning
stderr Resolver
resolver
    PingOpts { Bool
pingOptsQuiet :: PingOpts -> Bool
pingOptsQuiet :: Bool
pingOptsQuiet, pingOptsSRVPrefix :: PingOpts -> FilePath
pingOptsSRVPrefix = FilePath
srvPrefix }
    AcceptFilePath
acceptFilePath
    =
    Address (Unresolved SRVOrFilePathUnresolved)
-> IO ([Address Resolved], [AddressResolutionError])
forall (fpResolved :: ResolvedSRVOrFilePath).
Address (Unresolved fpResolved)
-> IO ([Address Resolved], [AddressResolutionError])
go
  where
    -- resolution loop
    go :: Address (Unresolved fpResolved)
       -> IO ([Address Resolved], [AddressResolutionError])

    -- 1. Resolve an SRV record
    go :: forall (fpResolved :: ResolvedSRVOrFilePath).
Address (Unresolved fpResolved)
-> IO ([Address Resolved], [AddressResolutionError])
go addr :: Address (Unresolved fpResolved)
addr@(SRV FilePath
dns) = do
      let hostname :: Domain
hostname = FilePath -> Domain
BS.Char.pack (FilePath -> Domain) -> FilePath -> Domain
forall a b. (a -> b) -> a -> b
$ case FilePath
srvPrefix of
                                      [] -> FilePath
dns
                                      FilePath
_  -> FilePath
srvPrefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"." FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dns
      r <- Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
DNS.lookupRaw Resolver
resolver Domain
hostname TYPE
DNS.SRV
      case r >>= flip DNS.fromDNSMessage selectSRV of
        Left DNSError
err -> do
          let err' :: AddressResolutionError
err' = SomeAddress -> DNSError -> AddressResolutionError
DNSError (Address (Unresolved fpResolved) -> SomeAddress
forall (versionNumber :: Stage).
Address versionNumber -> SomeAddress
SomeAddress Address (Unresolved fpResolved)
addr) DNSError
err
          Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (AddressResolutionError -> PingWarning
AddressResolutionError AddressResolutionError
err')
          case AcceptFilePath
acceptFilePath of
            AcceptFilePath
AddressMightBeAFilePath ->
              -- try resolve the SRV as a file path
              Address (Unresolved SRVOrFilePathUnresolved)
-> IO ([Address Resolved], [AddressResolutionError])
forall (fpResolved :: ResolvedSRVOrFilePath).
Address (Unresolved fpResolved)
-> IO ([Address Resolved], [AddressResolutionError])
go (FilePath -> Address (Unresolved SRVOrFilePathUnresolved)
FilePathOrDomain FilePath
dns)
            AcceptFilePath
AddressIsNotAFilePath ->
              ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [AddressResolutionError
err'])
        Right [(Domain, Word16, Word16, Word16, Word32)]
services ->
          [([Address Resolved], [AddressResolutionError])]
-> ([Address Resolved], [AddressResolutionError])
forall a b. [([a], [b])] -> ([a], [b])
concatBoth ([([Address Resolved], [AddressResolutionError])]
 -> ([Address Resolved], [AddressResolutionError]))
-> IO [([Address Resolved], [AddressResolutionError])]
-> IO ([Address Resolved], [AddressResolutionError])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Address (Unresolved SRVOrFilePathResolved)
 -> IO ([Address Resolved], [AddressResolutionError]))
-> [Address (Unresolved SRVOrFilePathResolved)]
-> IO [([Address Resolved], [AddressResolutionError])]
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 Address (Unresolved SRVOrFilePathResolved)
-> IO ([Address Resolved], [AddressResolutionError])
forall (fpResolved :: ResolvedSRVOrFilePath).
Address (Unresolved fpResolved)
-> IO ([Address Resolved], [AddressResolutionError])
go
            [ Domain -> Port -> Address (Unresolved SRVOrFilePathResolved)
Domain Domain
domain (Word16 -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port)
            | (Domain
domain, Word16
_, Word16
_, Word16
port, Word32
_ttl)  <- [(Domain, Word16, Word16, Word16, Word32)]
services
            ]
      where
        selectSRV :: DNSMessage -> [(Domain, Word16, Word16, Word16, Word32)]
selectSRV DNS.DNSMessage { Answers
answer :: Answers
answer :: DNSMessage -> Answers
DNS.answer } =
          [ (Domain
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 Domain
domain',
              rrttl :: ResourceRecord -> Word32
DNS.rrttl = Word32
ttl
            } <- Answers
answer
          ]

    -- 2. Resolved domain name or file path
    go addr :: Address (Unresolved fpResolved)
addr@(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
           Address (Unresolved SRVOrFilePathResolved)
-> IO ([Address Resolved], [AddressResolutionError])
forall (fpResolved :: ResolvedSRVOrFilePath).
Address (Unresolved fpResolved)
-> IO ([Address Resolved], [AddressResolutionError])
go (Domain -> Port -> Address (Unresolved SRVOrFilePathResolved)
Domain (FilePath -> Domain
BS.Char.pack FilePath
dnsname) Port
port)
             IO ([Address Resolved], [AddressResolutionError])
-> (([Address Resolved], [AddressResolutionError])
    -> IO ([Address Resolved], [AddressResolutionError]))
-> IO ([Address Resolved], [AddressResolutionError])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               ([], [AddressResolutionError]
errs) | AcceptFilePath
AddressMightBeAFilePath <- AcceptFilePath
acceptFilePath ->
                 -- dns query failed, let's try if it is a file path
                 FilePath -> IO Bool
doesFileExist FilePath
path IO Bool
-> (Bool -> IO ([Address Resolved], [AddressResolutionError]))
-> IO ([Address Resolved], [AddressResolutionError])
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], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath -> Address Resolved
FilePath FilePath
path], [AddressResolutionError]
errs)
                   Bool
False -> do
                     let err :: AddressResolutionError
err = FilePath -> AddressResolutionError
FilePathDoesNotExistError FilePath
path
                     Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (AddressResolutionError -> PingWarning
AddressResolutionError AddressResolutionError
err)
                     ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], AddressResolutionError
err AddressResolutionError
-> [AddressResolutionError] -> [AddressResolutionError]
forall a. a -> [a] -> [a]
: [AddressResolutionError]
errs)
               ([Address Resolved]
addrs, [AddressResolutionError]
errs) -> ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Address Resolved]
addrs, [AddressResolutionError]
errs)
         Maybe (FilePath, Port)
Nothing | AcceptFilePath
AddressMightBeAFilePath <- AcceptFilePath
acceptFilePath -> do
           FilePath -> IO Bool
doesFileExist FilePath
path IO Bool
-> (Bool -> IO ([Address Resolved], [AddressResolutionError]))
-> IO ([Address Resolved], [AddressResolutionError])
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], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath -> Address Resolved
FilePath FilePath
path], [])
             Bool
False -> do
               let err :: AddressResolutionError
err = FilePath -> AddressResolutionError
FilePathDoesNotExistError FilePath
path
               Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (AddressResolutionError -> PingWarning
AddressResolutionError AddressResolutionError
err)
               ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [AddressResolutionError
err])
         Maybe (FilePath, Port)
Nothing -> do
           ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [SomeAddress -> AddressResolutionError
NoPortNumberError (Address (Unresolved fpResolved) -> SomeAddress
forall (versionNumber :: Stage).
Address versionNumber -> SomeAddress
SomeAddress Address (Unresolved fpResolved)
addr)])

    -- 3. Resolve domain names
    go addr :: Address (Unresolved fpResolved)
addr@(Domain Domain
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 -> Domain -> IO (Either DNSError [IPv4])
DNS.lookupA Resolver
resolver Domain
hostname
      aaaa <- fmap (map IPv6) <$> DNS.lookupAAAA resolver hostname
      case a <>: aaaa of
        ([IP]
ips, [DNSError]
errs) -> do
          let errs' :: [AddressResolutionError]
errs' = [ SomeAddress -> DNSError -> AddressResolutionError
DNSError (Address (Unresolved fpResolved) -> SomeAddress
forall (versionNumber :: Stage).
Address versionNumber -> SomeAddress
SomeAddress Address (Unresolved fpResolved)
addr) DNSError
err | DNSError
err <- [DNSError]
errs ]
          (AddressResolutionError -> IO ())
-> [AddressResolutionError] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer IO PingWarning -> PingWarning -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO PingWarning
stderr (PingWarning -> IO ())
-> (AddressResolutionError -> PingWarning)
-> AddressResolutionError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressResolutionError -> PingWarning
AddressResolutionError) [AddressResolutionError]
errs'
          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
$ Domain -> [IP] -> Port -> PingWarning
DNSResolution Domain
hostname [IP]
ips Port
port
          ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
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 ]
                 , [AddressResolutionError]
errs'
                 )
      where
        (<>:) :: Eq e => Either e [a] -> Either e [a] -> ([a], [e])
        (Left e
e) <>: :: forall e a. Eq e => Either e [a] -> Either e [a] -> ([a], [e])
<>: Left e
e'   | e
e e -> e -> Bool
forall a. Eq a => a -> a -> Bool
/= e
e'
                               = ([], [e
e, e
e'])
                               | Bool
otherwise
                               = ([], [e
e])
        Right [a]
as <>: Left e
e'   = ([a]
as, [e
e'])
        Left e
e   <>: Right [a]
as  = ([a]
as, [e
e])
        Right [a]
as <>: Right [a]
as' = ([a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as', [])

    -- 4. Return ip address
    go (IP IP
addr Port
port) = ([Address Resolved], [AddressResolutionError])
-> IO ([Address Resolved], [AddressResolutionError])
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
  stdout <- IO (Tracer IO Text)
mkStdOutTracer
  stderr <- mkStdErrTracer
  headerTracer <- mkHeaderTracer opts stdout

  errors <-
    pingClients'
      (format pingOptsJson >$< stdout)
      (format pingOptsJson >$< stdout)
      headerTracer
      (toText >$< stderr)
      opts
      AddressMightBeAFilePath addresses
  unless (null errors)
    IO.exitFailure


data PingException
  = AddressResolutionException AddressResolutionError
  | PingClientException PingClientException
  deriving Int -> PingException -> ShowS
[PingException] -> ShowS
PingException -> FilePath
(Int -> PingException -> ShowS)
-> (PingException -> FilePath)
-> ([PingException] -> ShowS)
-> Show PingException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PingException -> ShowS
showsPrec :: Int -> PingException -> ShowS
$cshow :: PingException -> FilePath
show :: PingException -> FilePath
$cshowList :: [PingException] -> ShowS
showList :: [PingException] -> ShowS
Show

instance Exception PingException where
  displayException :: PingException -> FilePath
displayException (AddressResolutionException AddressResolutionError
e) = AddressResolutionError -> FilePath
forall e. Exception e => e -> FilePath
displayException AddressResolutionError
e
  displayException (PingClientException PingClientException
e)        = PingClientException -> FilePath
forall e. Exception e => e -> FilePath
displayException PingClientException
e

-- | A low level API which returns all address resolution & clients errors.
--
pingClients'
  :: Tracer IO (WithHost LogMsg)
  -- ^ trace log messages
  -> Tracer IO (WithHost LogInfoMsg)
  -- ^ info messages (e.g. RTTs, negotiated version numbers)
  -> Tracer IO Header
  -- ^ print header for ping measurements or tip information; it should be
  -- enabled if the first tracer is enabled.
  -> Tracer IO PingWarning
  -- ^ trace warning messages
  -> PingOpts
  -- ^ options for the ping command
  -> AcceptFilePath
  -- ^ accept file paths as addresses; if set to `AddressIsNotAFilePath` we'll
  -- never return file path related errors in `AddressResolutionError`.
  -> [Address (Unresolved SRVOrFilePathUnresolved)]
  -> IO [PingException]
  -- ^ returns two list:
  -- * list of resolve errors (printed with `PingWarning` tracer)
  -- * list of `pingClient` errors
pingClients' :: Tracer IO (WithHost LogMsg)
-> Tracer IO (WithHost LogInfoMsg)
-> Tracer IO Header
-> Tracer IO PingWarning
-> PingOpts
-> AcceptFilePath
-> [Address (Unresolved SRVOrFilePathUnresolved)]
-> IO [PingException]
pingClients' Tracer IO (WithHost LogMsg)
stdout Tracer IO (WithHost LogInfoMsg)
infoTracer Tracer IO Header
headerTracer Tracer IO PingWarning
stderr PingOpts
opts AcceptFilePath
acceptFilePath [Address (Unresolved SRVOrFilePathUnresolved)]
addresses = do
    -- resolved addresses
    rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
DNS.defaultResolvConf
    (resolvedAddresses, resolveErrors) <-
      DNS.withResolver rs $ \Resolver
resolver ->
        [([Address Resolved], [AddressResolutionError])]
-> ([Address Resolved], [AddressResolutionError])
forall a b. [([a], [b])] -> ([a], [b])
concatBoth ([([Address Resolved], [AddressResolutionError])]
 -> ([Address Resolved], [AddressResolutionError]))
-> IO [([Address Resolved], [AddressResolutionError])]
-> IO ([Address Resolved], [AddressResolutionError])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Address (Unresolved SRVOrFilePathUnresolved)
 -> IO ([Address Resolved], [AddressResolutionError]))
-> [Address (Unresolved SRVOrFilePathUnresolved)]
-> IO [([Address Resolved], [AddressResolutionError])]
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
-> AcceptFilePath
-> Address (Unresolved SRVOrFilePathUnresolved)
-> IO ([Address Resolved], [AddressResolutionError])
resolveAddress Tracer IO PingWarning
stderr Resolver
resolver PingOpts
opts AcceptFilePath
acceptFilePath) [Address (Unresolved SRVOrFilePathUnresolved)]
addresses
    sockAddrs
      <- catMaybes
         <$> traverse
               (\case
                  (IP ip :: IP
ip@IPv4{} Port
port) ->
                    [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
maybeHead ([AddrInfo] -> Maybe AddrInfo)
-> IO [AddrInfo] -> IO (Maybe 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))
                  (IP ip :: IP
ip@IPv6{} Port
port) ->
                    [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
maybeHead ([AddrInfo] -> Maybe AddrInfo)
-> IO [AddrInfo] -> IO (Maybe 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))
                  (FilePath FilePath
path) -> do
                    Maybe AddrInfo -> IO (Maybe AddrInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AddrInfo -> IO (Maybe AddrInfo))
-> Maybe AddrInfo -> IO (Maybe AddrInfo)
forall a b. (a -> b) -> a -> b
$ AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$
                      [AddrInfoFlag]
-> Family
-> SocketType
-> CInt
-> SockAddr
-> Maybe FilePath
-> AddrInfo
Socket.AddrInfo
                       []
                       Family
Socket.AF_UNIX
                       SocketType
Socket.Stream
                       CInt
Socket.defaultProtocol
                       (FilePath -> SockAddr
Socket.SockAddrUnix FilePath
path)
                       Maybe FilePath
forall a. Maybe a
Nothing
               )
               resolvedAddresses

    signalVar <- newSignalVar (Socket.addrAddress <$> sockAddrs)
    results <-
      mapConcurrently
        (pingClient' stdout infoTracer headerTracer stderr opts signalVar)
        sockAddrs
    return $ (AddressResolutionException <$> resolveErrors)
          ++ (PingClientException <$> lefts results)


-- | Run a single ping client.
--
pingClient
  :: Tracer IO (WithHost LogMsg)
  -- ^ stdout
  -> Tracer IO (WithHost LogInfoMsg)
  -- ^ info tracer
  -> Tracer IO Header
  -> Tracer IO PingWarning
  -- ^ stderr
  -> PingOpts
  -> AddrInfo
  -> IO (Either PingClientException ())
pingClient :: Tracer IO (WithHost LogMsg)
-> Tracer IO (WithHost LogInfoMsg)
-> Tracer IO Header
-> Tracer IO PingWarning
-> PingOpts
-> AddrInfo
-> IO (Either PingClientException ())
pingClient Tracer IO (WithHost LogMsg)
stdout Tracer IO (WithHost LogInfoMsg)
infoTracer Tracer IO Header
headerTracer Tracer IO PingWarning
stderr PingOpts
opts AddrInfo
addrInfo = do
  signalVar <- [SockAddr] -> IO (SignalVar SockAddr)
forall addr. Ord addr => [addr] -> IO (SignalVar addr)
newSignalVar [AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
addrInfo]
  pingClient' stdout infoTracer headerTracer stderr opts signalVar addrInfo


-- | Low level API to run a single ping client.
--
pingClient'
  :: Tracer IO (WithHost LogMsg)
  -> Tracer IO (WithHost LogInfoMsg)
  -> Tracer IO Header
  -> Tracer IO PingWarning
  -> PingOpts
  -> SignalVar SockAddr
  -> AddrInfo
  -> IO (Either PingClientException ())
pingClient' :: Tracer IO (WithHost LogMsg)
-> Tracer IO (WithHost LogInfoMsg)
-> Tracer IO Header
-> Tracer IO PingWarning
-> PingOpts
-> SignalVar SockAddr
-> AddrInfo
-> IO (Either PingClientException ())
pingClient' Tracer IO (WithHost LogMsg)
stdout Tracer IO (WithHost LogInfoMsg)
infoTracer Tracer IO Header
headerTracer 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 SockAddr
signalVar AddrInfo
addrInfo =
  IO () -> IO (Either PingClientException ())
handlePingClientExceptions (IO () -> IO (Either PingClientException ()))
-> IO () -> IO (Either PingClientException ())
forall a b. (a -> b) -> a -> b
$
  SignalVar SockAddr -> SockAddr -> (Signal -> IO ()) -> IO ()
forall addr a.
Ord addr =>
SignalVar addr -> addr -> (Signal -> IO a) -> IO a
withSignal SignalVar SockAddr
signalVar SockAddr
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 -> CInt -> IO Socket
Socket.socket (AddrInfo -> Family
Socket.addrFamily AddrInfo
addrInfo) SocketType
Socket.Stream CInt
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
addrInfo 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 :: CInt
sl_onoff  = CInt
1
              , sl_linger :: CInt
sl_linger = CInt
0
              }
        let someProtocol :: SomeProtocolFlavour
            someProtocol :: SomeProtocolFlavour
someProtocol = case AddrInfo -> Family
Socket.addrFamily AddrInfo
addrInfo of
              Family
Socket.AF_UNIX -> ProtocolFlavour NodeToClientVersion NodeToClientVersionData
-> SomeProtocolFlavour
forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber, ToText versionNumber) =>
ProtocolFlavour versionNumber versionData -> SomeProtocolFlavour
SomeProtocolFlavour ProtocolFlavour NodeToClientVersion NodeToClientVersionData
NodeToClient
              Family
_              -> ProtocolFlavour NodeToNodeVersion NodeToNodeVersionData
-> SomeProtocolFlavour
forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber, ToText versionNumber) =>
ProtocolFlavour versionNumber versionData -> SomeProtocolFlavour
SomeProtocolFlavour ProtocolFlavour NodeToNodeVersion NodeToNodeVersionData
NodeToNode
        case SomeProtocolFlavour
someProtocol of
          SomeProtocolFlavour ProtocolFlavour versionNumber versionData
protocol -> ProtocolFlavour versionNumber versionData
-> Signal -> Socket -> IO ()
forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber, ToText versionNumber) =>
ProtocolFlavour versionNumber versionData
-> Signal -> Socket -> IO ()
runPingClient ProtocolFlavour versionNumber versionData
protocol Signal
sig Socket
sd
      )
  where
    addr :: SockAddr
    addr :: SockAddr
addr = AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
addrInfo

    handlePingClientExceptions
      :: IO ()
      -> IO (Either PingClientException ())
    handlePingClientExceptions :: IO () -> IO (Either PingClientException ())
handlePingClientExceptions IO ()
io =
      (() -> Either PingClientException ()
forall a b. b -> Either a b
Right (() -> Either PingClientException ())
-> IO () -> IO (Either PingClientException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ()
io)
      IO (Either PingClientException ())
-> (SomeException -> IO (Either PingClientException ()))
-> IO (Either PingClientException ())
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \case
        SomeException
err | Just IOError
e <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err -> Either PingClientException () -> IO (Either PingClientException ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PingClientException -> Either PingClientException ()
forall a b. a -> Either a b
Left (IOError -> SockAddr -> PingClientException
IOException IOError
e SockAddr
addr))
            | Just DeserialiseFailure
e <- SomeException -> Maybe DeserialiseFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err -> Either PingClientException () -> IO (Either PingClientException ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PingClientException -> Either PingClientException ()
forall a b. a -> Either a b
Left (DeserialiseFailure -> SockAddr -> PingClientException
DecodingException DeserialiseFailure
e SockAddr
addr))
            | Just Error
e <- SomeException -> Maybe Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err -> Either PingClientException () -> IO (Either PingClientException ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PingClientException -> Either PingClientException ()
forall a b. a -> Either a b
Left (Error -> SockAddr -> PingClientException
MuxException Error
e SockAddr
addr))
            | Just PingClientException
e <- SomeException -> Maybe PingClientException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err -> Either PingClientException () -> IO (Either PingClientException ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PingClientException -> Either PingClientException ()
forall a b. a -> Either a b
Left PingClientException
e)
            | Bool
otherwise
            -> SomeException -> IO (Either PingClientException ())
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err

    runPingClient :: forall versionNumber versionData.
                     ( Acceptable versionData
                     , Queryable versionData
                     , NFData versionData
                     , Ord versionNumber
                     , Show versionNumber
                     , NFData versionNumber
                     , ToJSON versionNumber
                     , ToText versionNumber
                     )
                  => ProtocolFlavour versionNumber versionData
                  -> Signal
                  -> Socket.Socket
                  -> IO ()
    runPingClient :: forall versionNumber versionData.
(Acceptable versionData, Queryable versionData, NFData versionData,
 Ord versionNumber, Show versionNumber, NFData versionNumber,
 ToJSON versionNumber, ToText versionNumber) =>
ProtocolFlavour versionNumber versionData
-> Signal -> Socket -> IO ()
runPingClient ProtocolFlavour versionNumber versionData
protocol Signal
sig Socket
sd = do
      let stdout' :: Tracer IO LogMsg
          stdout' :: Tracer IO LogMsg
stdout' =  SockAddr -> LogMsg -> WithHost LogMsg
forall a. SockAddr -> a -> WithHost a
WithHost SockAddr
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

          infoTracer' :: Tracer IO LogInfoMsg
          infoTracer' :: Tracer IO LogInfoMsg
infoTracer' = SockAddr -> LogInfoMsg -> WithHost LogInfoMsg
forall a. SockAddr -> a -> WithHost a
WithHost SockAddr
addr (LogInfoMsg -> WithHost LogInfoMsg)
-> Tracer IO (WithHost LogInfoMsg) -> Tracer IO LogInfoMsg
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer IO (WithHost LogInfoMsg)
infoTracer

      !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 SockAddr
addr 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 addr
      !t0_e <- getMonotonicTime

      traceWith infoTracer' (LogNetworkRTT $ 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
          PingClientException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ProtocolLimitFailure -> SockAddr -> PingClientException
ProtocolLimitException ProtocolLimitFailure
err SockAddr
addr)
        Right (Left HandshakeProtocolError versionNumber
err', DiffTime
rtt) -> do
          Tracer IO LogInfoMsg -> LogInfoMsg -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO LogInfoMsg
infoTracer' (HandshakeRTT -> LogInfoMsg
LogHandshakeRTT (HandshakeRTT -> LogInfoMsg) -> HandshakeRTT -> LogInfoMsg
forall a b. (a -> b) -> a -> b
$ DiffTime -> HandshakeRTT
HandshakeRTT DiffTime
rtt)
          PingClientException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (HandshakeProtocolError versionNumber
-> SockAddr -> PingClientException
forall versionNumber.
Show versionNumber =>
HandshakeProtocolError versionNumber
-> SockAddr -> PingClientException
HandshakeException HandshakeProtocolError versionNumber
err' SockAddr
addr)
        Right (Right HandshakeResult () versionNumber versionData
r', DiffTime
rtt) -> do
          Tracer IO LogInfoMsg -> LogInfoMsg -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO LogInfoMsg
infoTracer' (HandshakeRTT -> LogInfoMsg
LogHandshakeRTT (HandshakeRTT -> LogInfoMsg) -> HandshakeRTT -> LogInfoMsg
forall a b. (a -> b) -> a -> b
$ 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
              Tracer IO LogInfoMsg -> LogInfoMsg -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO LogInfoMsg
infoTracer' (NegotiatedVersion versionNumber -> LogInfoMsg
forall versionNumber.
(Show versionNumber, ToText versionNumber, ToJSON versionNumber) =>
NegotiatedVersion versionNumber -> LogInfoMsg
LogNegotiatedVersion (NegotiatedVersion versionNumber -> LogInfoMsg)
-> NegotiatedVersion versionNumber -> LogInfoMsg
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 Domain -> 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 Domain
Decoder s (HeaderHash ChainSyncBlock)
forall s. Decoder s Domain
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
$ Signal
-> Tracer IO LogMsg
-> Tracer IO Header
-> ChainSyncClient
     ChainSyncHeader ChainSyncHeader ChainSyncTip IO ()
chainSyncClient Signal
sig Tracer IO LogMsg
stdout' Tracer IO Header
headerTracer))
                        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
-> Tracer IO LogMsg
-> Tracer IO Header
-> TDigest 5
-> KeepAliveClient IO ()
keepAliveClient
                                PingOpts
opts
                                Signal
sig
                                Tracer IO LogMsg
stdout'
                                Tracer IO Header
headerTracer
                                ([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

instance ToText String where
  toText :: FilePath -> Text
toText = FilePath -> Text
TL.pack

instance ToText TL.Text where
  toText :: Text -> Text
toText = Text -> Text
forall a. a -> a
id

instance ToText NodeToClientVersion where
  toText :: NodeToClientVersion -> Text
toText = FilePath -> Text
TL.pack (FilePath -> Text)
-> (NodeToClientVersion -> FilePath) -> NodeToClientVersion -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeToClientVersion -> FilePath
forall a. Show a => a -> FilePath
show

instance ToText NodeToNodeVersion where
  toText :: NodeToNodeVersion -> Text
toText = FilePath -> Text
TL.pack (FilePath -> Text)
-> (NodeToNodeVersion -> FilePath) -> NodeToNodeVersion -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeToNodeVersion -> FilePath
forall a. Show a => a -> FilePath
show

data WithHost a = WithHost SockAddr a
  deriving Int -> WithHost a -> ShowS
[WithHost a] -> ShowS
WithHost a -> FilePath
(Int -> WithHost a -> ShowS)
-> (WithHost a -> FilePath)
-> ([WithHost a] -> ShowS)
-> Show (WithHost a)
forall a. Show a => Int -> WithHost a -> ShowS
forall a. Show a => [WithHost a] -> ShowS
forall a. Show a => WithHost a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithHost a -> ShowS
showsPrec :: Int -> WithHost a -> ShowS
$cshow :: forall a. Show a => WithHost a -> FilePath
show :: WithHost a -> FilePath
$cshowList :: forall a. Show a => [WithHost a] -> ShowS
showList :: [WithHost a] -> ShowS
Show

instance ToText a => ToText (WithHost a) where
  toText :: WithHost a -> Text
toText (WithHost SockAddr
host a
a) =
    FilePath -> Text
TL.pack (FilePath -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-47s" (SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
host FilePath -> ShowS
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 SockAddr
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
$ SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
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
.= SockAddr -> FilePath
forall a. Show a => a -> FilePath
show SockAddr
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
  deriving Int -> NegotiatedVersion versionNumber -> ShowS
[NegotiatedVersion versionNumber] -> ShowS
NegotiatedVersion versionNumber -> FilePath
(Int -> NegotiatedVersion versionNumber -> ShowS)
-> (NegotiatedVersion versionNumber -> FilePath)
-> ([NegotiatedVersion versionNumber] -> ShowS)
-> Show (NegotiatedVersion versionNumber)
forall versionNumber.
Show versionNumber =>
Int -> NegotiatedVersion versionNumber -> ShowS
forall versionNumber.
Show versionNumber =>
[NegotiatedVersion versionNumber] -> ShowS
forall versionNumber.
Show versionNumber =>
NegotiatedVersion versionNumber -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall versionNumber.
Show versionNumber =>
Int -> NegotiatedVersion versionNumber -> ShowS
showsPrec :: Int -> NegotiatedVersion versionNumber -> ShowS
$cshow :: forall versionNumber.
Show versionNumber =>
NegotiatedVersion versionNumber -> FilePath
show :: NegotiatedVersion versionNumber -> FilePath
$cshowList :: forall versionNumber.
Show versionNumber =>
[NegotiatedVersion versionNumber] -> ShowS
showList :: [NegotiatedVersion versionNumber] -> ShowS
Show

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 -> ShowS
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 vs) =
    TL.pack $ printf "Queried versions: %s" (unwords $ show <$> vs)

instance ToJSON versionNumber
      => ToJSON (QueriedVersions versionNumber) where
  toJSON (QueriedVersions vs) =
    object ["queried_versions" .= toJSON vs]
-}


newtype NetworkRTT = NetworkRTT Double
  deriving Int -> NetworkRTT -> ShowS
[NetworkRTT] -> ShowS
NetworkRTT -> FilePath
(Int -> NetworkRTT -> ShowS)
-> (NetworkRTT -> FilePath)
-> ([NetworkRTT] -> ShowS)
-> Show NetworkRTT
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkRTT -> ShowS
showsPrec :: Int -> NetworkRTT -> ShowS
$cshow :: NetworkRTT -> FilePath
show :: NetworkRTT -> FilePath
$cshowList :: [NetworkRTT] -> ShowS
showList :: [NetworkRTT] -> ShowS
Show

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
  deriving Int -> HandshakeRTT -> ShowS
[HandshakeRTT] -> ShowS
HandshakeRTT -> FilePath
(Int -> HandshakeRTT -> ShowS)
-> (HandshakeRTT -> FilePath)
-> ([HandshakeRTT] -> ShowS)
-> Show HandshakeRTT
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HandshakeRTT -> ShowS
showsPrec :: Int -> HandshakeRTT -> ShowS
$cshow :: HandshakeRTT -> FilePath
show :: HandshakeRTT -> FilePath
$cshowList :: [HandshakeRTT] -> ShowS
showList :: [HandshakeRTT] -> ShowS
Show

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)]

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

concatBoth :: [([a], [b])] -> ([a], [b])
concatBoth :: forall a b. [([a], [b])] -> ([a], [b])
concatBoth [([a], [b])]
a = ((([a], [b]) -> [a]) -> [([a], [b])] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([a], [b]) -> [a]
forall a b. (a, b) -> a
fst [([a], [b])]
a, (([a], [b]) -> [b]) -> [([a], [b])] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([a], [b]) -> [b]
forall a b. (a, b) -> b
snd [([a], [b])]
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 (ShowS
forall a. [a] -> [a]
reverse FilePath
acc, FilePath
as)
      go !FilePath
acc (Char
a:FilePath
as)
        = FilePath -> FilePath -> Maybe (FilePath, FilePath)
go (Char
aChar -> ShowS
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

mkHeaderTracer
  :: PingOpts
  -> Tracer IO TL.Text
  -> IO (Tracer IO Header)
mkHeaderTracer :: PingOpts -> Tracer IO Text -> IO (Tracer IO Header)
mkHeaderTracer PingOpts { pingOptsJson :: PingOpts -> LogFormat
pingOptsJson = LogFormat
AsJSON } Tracer IO Text
_ = Tracer IO Header -> IO (Tracer IO Header)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer IO Header
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
mkHeaderTracer PingOpts { pingOptsJson :: PingOpts -> LogFormat
pingOptsJson = LogFormat
AsText, ColorMode
pingOptsColor :: PingOpts -> ColorMode
pingOptsColor :: ColorMode
pingOptsColor } Tracer IO Text
stdout = do
  headerVar <- IO HeaderVar
newHeaderVar
  return $ mkTracer $ \Header
hdr -> 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
        traceWith stdout (if useColor
                             then "\ESC[1m" <> toText hdr <> "\ESC[0m"
                             else toText 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 ()


mkStdOutTracer :: IO (Tracer IO TL.Text)
mkStdOutTracer :: IO (Tracer IO Text)
mkStdOutTracer = do
  lock <- () -> 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
  return $ mkTracer $ \Text
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 ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
    Text -> IO ()
TL.putStrLn Text
msg


mkStdErrTracer :: IO (Tracer IO TL.Text)
mkStdErrTracer :: IO (Tracer IO Text)
mkStdErrTracer = do
  lock <- () -> IO (MVar IO ())
forall a. a -> IO (MVar IO a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar ()
  IO.hSetBuffering IO.stderr IO.LineBuffering
  return $ mkTracer $ \Text
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 ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
    Handle -> Text -> IO ()
TL.hPutStrLn Handle
IO.stderr Text
msg