{-# LANGUAGE DuplicateRecordFields #-}

-- | Utilities used across hydra-cluster
module Hydra.Cluster.Util where

import Hydra.Prelude

import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Hydra.Cardano.Api (
  Key (VerificationKey, getVerificationKey),
  NetworkId,
  PaymentKey,
  SigningKey,
  TextEnvelopeError (TextEnvelopeAesonDecodeError),
  TxId,
  deserialiseFromTextEnvelope,
  textEnvelopeToJSON,
 )
import Hydra.Cluster.Fixture (Actor, actorName, fundsOf)
import Hydra.Node.UnsyncedPeriod (defaultUnsyncedPeriodFor)
import Hydra.Options (
  CardanoChainConfig (..),
  ChainBackendOptions (..),
  ChainConfig (..),
  DirectOptions (..),
  defaultCardanoChainConfig,
 )
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.DepositPeriod (DepositPeriod)
import Hydra.Tx.DepositPeriod qualified as DP
import Hydra.Tx.Secret (Secret, mkSecret)
import Paths_hydra_cluster qualified as Pkg
import System.FilePath ((<.>), (</>))
import Test.Hydra.Prelude (failure)
import Test.Hydra.Tx.Gen (genSigningKey)
import Test.QuickCheck (generate)

-- | Lookup a config file similar reading a file from disk.
-- If the env variable `HYDRA_CONFIG_DIR` is set, filenames will be
-- resolved relative to its value otherwise they will be looked up in the
-- package's data path.
readConfigFile :: FilePath -> IO ByteString
readConfigFile :: String -> IO ByteString
readConfigFile String
source = do
  String
filename <-
    String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
lookupEnv String
"HYDRA_CONFIG_DIR"
      IO (Maybe String) -> (Maybe String -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO String
Pkg.getDataFileName (String
"config" String -> String -> String
</> String
source)) (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> (String -> String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
source))
  String -> IO ByteString
BS.readFile String
filename

-- | Get the "well-known" keys for given actor. The signing key is
-- 'Secret'-wrapped so callers cannot accidentally log or serialise it.
keysFor :: Actor -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor :: Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
actor = do
  ByteString
bs <- String -> IO ByteString
readConfigFile (String
"credentials" String -> String -> String
</> Actor -> String
actorName Actor
actor String -> String -> String
<.> String
"sk")
  let res :: Either TextEnvelopeError (SigningKey PaymentKey)
res =
        (String -> TextEnvelopeError)
-> Either String TextEnvelope
-> Either TextEnvelopeError TextEnvelope
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> TextEnvelopeError
TextEnvelopeAesonDecodeError (ByteString -> Either String TextEnvelope
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bs)
          Either TextEnvelopeError TextEnvelope
-> (TextEnvelope
    -> Either TextEnvelopeError (SigningKey PaymentKey))
-> Either TextEnvelopeError (SigningKey PaymentKey)
forall a b.
Either TextEnvelopeError a
-> (a -> Either TextEnvelopeError b) -> Either TextEnvelopeError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextEnvelope -> Either TextEnvelopeError (SigningKey PaymentKey)
forall a.
HasTextEnvelope a =>
TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope
  case Either TextEnvelopeError (SigningKey PaymentKey)
res of
    Left TextEnvelopeError
err ->
      String
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> String
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
forall a b. (a -> b) -> a -> b
$ String
"cannot decode text envelope from '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
bs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"', error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TextEnvelopeError -> String
forall b a. (Show a, IsString b) => a -> b
show TextEnvelopeError
err
    Right SigningKey PaymentKey
sk -> (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk, SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk)

-- | Create and save new signing key at the provided path, returning the
-- key 'Secret'-wrapped.
-- NOTE: Uses 'TextEnvelope' format.
createAndSaveSigningKey :: FilePath -> IO (Secret (SigningKey PaymentKey))
createAndSaveSigningKey :: String -> IO (Secret (SigningKey PaymentKey))
createAndSaveSigningKey String
path = do
  SigningKey PaymentKey
sk <- Gen (SigningKey PaymentKey) -> IO (SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (SigningKey PaymentKey)
genSigningKey
  String -> LByteString -> IO ()
forall (m :: * -> *). MonadIO m => String -> LByteString -> m ()
writeFileLBS String
path (LByteString -> IO ()) -> LByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe TextEnvelopeDescr -> SigningKey PaymentKey -> LByteString
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> LByteString
textEnvelopeToJSON (TextEnvelopeDescr -> Maybe TextEnvelopeDescr
forall a. a -> Maybe a
Just TextEnvelopeDescr
"Key used to commit funds into a Head") SigningKey PaymentKey
sk
  Secret (SigningKey PaymentKey)
-> IO (Secret (SigningKey PaymentKey))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk)

-- | Expected time between blocks (on average)
type BlockTime = NominalDiffTime

-- | Timing parameters that determine the behavior of a (cluster of) hydra-node.
data Timing = Timing
  { Timing -> NominalDiffTime
blockTime :: BlockTime
  , Timing -> ContestationPeriod
contestationPeriod :: ContestationPeriod
  , Timing -> DepositPeriod
depositPeriod :: DepositPeriod
  , Timing -> DepositPeriod
depositActivation :: DepositPeriod
  -- ^ Time a deposit must mature before it becomes active. Configured
  -- independently from 'depositPeriod'; the smart constructors default it to the
  -- same value so deposits activate as fast as they expire, but tests can set it
  -- separately to exercise decoupled activation.
  }
  deriving stock (Int -> Timing -> String -> String
[Timing] -> String -> String
Timing -> String
(Int -> Timing -> String -> String)
-> (Timing -> String)
-> ([Timing] -> String -> String)
-> Show Timing
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Timing -> String -> String
showsPrec :: Int -> Timing -> String -> String
$cshow :: Timing -> String
show :: Timing -> String
$cshowList :: [Timing] -> String -> String
showList :: [Timing] -> String -> String
Show)

-- | Truncate a duration to a whole-second 'DepositPeriod'.
truncatedDepositPeriod :: NominalDiffTime -> DepositPeriod
truncatedDepositPeriod :: NominalDiffTime -> DepositPeriod
truncatedDepositPeriod = NominalDiffTime -> DepositPeriod
DP.DepositPeriod (NominalDiffTime -> DepositPeriod)
-> (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime
-> DepositPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime)
-> (NominalDiffTime -> Integer)
-> NominalDiffTime
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Integer
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate

-- | Set up reasonable timing parameters for testing given a 'BlockTime'.
mkTestTiming :: BlockTime -> Timing
mkTestTiming :: NominalDiffTime -> Timing
mkTestTiming = Int -> NominalDiffTime -> Timing
mkTestTiming' Int
1

-- | Like 'mkTestTiming' but scales 'depositPeriod' by the number of concurrent
-- deposits expected. Each increment tx must be processed sequentially on-chain,
-- so N concurrent deposits require N times the base deposit period.
mkTestTiming' :: Int -> BlockTime -> Timing
mkTestTiming' :: Int -> NominalDiffTime -> Timing
mkTestTiming' Int
numDeposits NominalDiffTime
blockTime =
  Timing
    { NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime
    , $sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod = NominalDiffTime -> ContestationPeriod
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (NominalDiffTime -> ContestationPeriod)
-> NominalDiffTime -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
    , DepositPeriod
$sel:depositPeriod:Timing :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod
    , $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
depositPeriod
    }
 where
  depositPeriod :: DepositPeriod
depositPeriod = NominalDiffTime -> DepositPeriod
truncatedDepositPeriod (NominalDiffTime -> DepositPeriod)
-> NominalDiffTime -> DepositPeriod
forall a b. (a -> b) -> a -> b
$ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numDeposits NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime

-- | Get a timeout until a deposit should have happened given a 'Timing'. A
-- deposit becomes active after 'depositActivation' and then needs about one
-- 'depositPeriod' to be picked up and incremented, so both are accounted for
-- (with the defaults where they are equal this is @2 * depositPeriod@).
--
-- The slack term covers the two on-chain round trips (deposit and increment:
-- submit, include, observe) plus multi-node processing. Those costs are
-- dominated by fixed latencies, not by block time, so the slack has a
-- constant floor; with the devnet's 0.1s blocks a pure @5 * blockTime@ came
-- to 0.5s and timed out regularly on loaded CI runners.
depositTimeout :: Timing -> NominalDiffTime
depositTimeout :: Timing -> NominalDiffTime
depositTimeout Timing{NominalDiffTime
$sel:blockTime:Timing :: Timing -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime, DepositPeriod
$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
$sel:depositActivation:Timing :: Timing -> DepositPeriod
depositActivation :: DepositPeriod
depositActivation} =
  DepositPeriod -> NominalDiffTime
DP.toNominalDiffTime DepositPeriod
depositActivation NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ DepositPeriod -> NominalDiffTime
DP.toNominalDiffTime DepositPeriod
depositPeriod NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
max NominalDiffTime
5 (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime)

-- | Budget for observing the effect of one L1 transaction on the API:
-- submission, block inclusion, chain-follower observation and node
-- processing. The constant floor covers the fixed latencies, which dominate
-- at devnet block times; a pure blockTime multiple (e.g. a literal 3s) fired
-- regularly on loaded CI runners.
onChainObservationBudget :: NominalDiffTime -> NominalDiffTime
onChainObservationBudget :: NominalDiffTime -> NominalDiffTime
onChainObservationBudget NominalDiffTime
blockTime = NominalDiffTime
5 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime

-- | Budget for a hydra-node (re)start up to its Greetings. Process spawn,
-- etcd bootstrap and websocket connect are fixed costs, unrelated to block
-- time, so this is a constant.
nodeStartupBudget :: NominalDiffTime
nodeStartupBudget :: NominalDiffTime
nodeStartupBudget = NominalDiffTime
20

-- | Create a (test) chain config for a given actor.
chainConfigFor ::
  HasCallStack =>
  Actor ->
  FilePath ->
  ChainBackendOptions ->
  -- | Transaction ids at which Hydra scripts should have been published.
  [TxId] ->
  [Actor] ->
  Timing ->
  IO ChainConfig
chainConfigFor :: HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
me String
targetDir ChainBackendOptions
opts [TxId]
txids [Actor]
actors Timing
timing =
  HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
me String
targetDir ChainBackendOptions
opts [TxId]
txids [Actor]
actors ContestationPeriod
contestationPeriod DepositPeriod
depositPeriod DepositPeriod
depositActivation
 where
  Timing{ContestationPeriod
$sel:contestationPeriod:Timing :: Timing -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
$sel:depositActivation:Timing :: Timing -> DepositPeriod
depositActivation :: DepositPeriod
depositActivation} = Timing
timing

chainConfigFor' ::
  HasCallStack =>
  Actor ->
  FilePath ->
  ChainBackendOptions ->
  -- | Transaction ids at which Hydra scripts should have been published.
  [TxId] ->
  [Actor] ->
  ContestationPeriod ->
  DepositPeriod ->
  -- | Deposit activation, independent from the deposit period.
  DepositPeriod ->
  IO ChainConfig
chainConfigFor' :: HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
me String
targetDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor]
them ContestationPeriod
contestationPeriod DepositPeriod
depositPeriod DepositPeriod
depositActivation = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor
me Actor -> [Actor] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Actor]
them) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      Actor -> String
forall b a. (Show a, IsString b) => a -> b
show Actor
me String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must not be in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Actor] -> String
forall b a. (Show a, IsString b) => a -> b
show [Actor]
them

  Actor -> String -> IO ()
copyFile Actor
me String
"vk"
  Actor -> String -> IO ()
copyFile Actor
me String
"sk"
  Actor -> String -> IO ()
copyFile (Actor -> Actor
fundsOf Actor
me) String
"vk"
  Actor -> String -> IO ()
copyFile (Actor -> Actor
fundsOf Actor
me) String
"sk"

  [Actor] -> (Actor -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Actor]
them ((Actor -> IO ()) -> IO ()) -> (Actor -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Actor
actor ->
    Actor -> String -> IO ()
copyFile Actor
actor String
"vk"
  ChainConfig -> IO ChainConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainConfig -> IO ChainConfig) -> ChainConfig -> IO ChainConfig
forall a b. (a -> b) -> a -> b
$
    CardanoChainConfig -> ChainConfig
Cardano
      CardanoChainConfig
defaultCardanoChainConfig
        { hydraScriptsTxId
        , cardanoSigningKey = actorFilePath me "sk"
        , cardanoVerificationKeys = [actorFilePath himOrHer "vk" | himOrHer <- them]
        , contestationPeriod
        , depositPeriod
        , depositActivation
        , unsyncedPeriod = defaultUnsyncedPeriodFor contestationPeriod
        , chainBackendOptions = opts
        }
 where
  actorFilePath :: Actor -> String -> String
actorFilePath Actor
actor String
fileType = String
targetDir String -> String -> String
</> Actor -> String -> String
actorFileName Actor
actor String
fileType
  actorFileName :: Actor -> String -> String
actorFileName Actor
actor String
fileType = Actor -> String
actorName Actor
actor String -> String -> String
<.> String
fileType

  copyFile :: Actor -> String -> IO ()
copyFile Actor
actor String
fileType = do
    let fileName :: String
fileName = Actor -> String -> String
actorFileName Actor
actor String
fileType
        filePath :: String
filePath = Actor -> String -> String
actorFilePath Actor
actor String
fileType
    String -> IO ByteString
readConfigFile (String
"credentials" String -> String -> String
</> String
fileName) IO ByteString -> (ByteString -> 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
>>= String -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
writeFileBS String
filePath

modifyConfig :: (CardanoChainConfig -> CardanoChainConfig) -> ChainConfig -> ChainConfig
modifyConfig :: (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig CardanoChainConfig -> CardanoChainConfig
fn = \case
  Cardano CardanoChainConfig
config -> CardanoChainConfig -> ChainConfig
Cardano (CardanoChainConfig -> ChainConfig)
-> CardanoChainConfig -> ChainConfig
forall a b. (a -> b) -> a -> b
$ CardanoChainConfig -> CardanoChainConfig
fn CardanoChainConfig
config
  ChainConfig
x -> ChainConfig
x

setNetworkId :: NetworkId -> ChainConfig -> ChainConfig
setNetworkId :: NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId = \case
  Cardano config :: CardanoChainConfig
config@CardanoChainConfig{ChainBackendOptions
$sel:chainBackendOptions:CardanoChainConfig :: CardanoChainConfig -> ChainBackendOptions
chainBackendOptions :: ChainBackendOptions
chainBackendOptions} ->
    case ChainBackendOptions
chainBackendOptions of
      Direct direct :: DirectOptions
direct@DirectOptions{} -> CardanoChainConfig -> ChainConfig
Cardano CardanoChainConfig
config{chainBackendOptions = Direct direct{networkId = networkId}}
      ChainBackendOptions
_ -> CardanoChainConfig -> ChainConfig
Cardano CardanoChainConfig
config
  ChainConfig
x -> ChainConfig
x