module Hydra.Node.Environment where

import Hydra.Prelude hiding (show)

import Data.Aeson (object, withObject, (.:), (.=))
import Hydra.Node.UnsyncedPeriod (UnsyncedPeriod)
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.Crypto (HydraKey, SigningKey, generateSigningKey)
import Hydra.Tx.DepositPeriod (DepositPeriod)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.OnChainId (OnChainId)
import Hydra.Tx.Party (Party)
import Hydra.Tx.Secret (Secret)
import Text.Show (Show (..))

data Environment = Environment
  { Environment -> Party
party :: Party
  -- ^ This is the p_i from the paper
  , -- XXX: In the long run we would not want to keep the signing key in memory,
    -- i.e. have an 'Effect' for signing or so.
    Environment -> Secret (SigningKey HydraKey)
signingKey :: Secret (SigningKey HydraKey)
  , Environment -> [Party]
otherParties :: [Party]
  , -- XXX: Improve naming
    Environment -> [OnChainId]
participants :: [OnChainId]
  , Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
  , Environment -> DepositPeriod
depositPeriod :: DepositPeriod
  , Environment -> DepositPeriod
depositActivation :: DepositPeriod
  -- ^ Time a deposit must mature before it is considered active. Controls only
  -- the Inactive -> Active transition, independently of 'depositPeriod'.
  , Environment -> UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
  -- ^ Period of time after which we consider the node becoming unsynced with the chain.
  -- Beyond this period the node will refuse to process new transactions and signing snapshots.
  , Environment -> Text
configuredPeers :: Text
  -- ^ Configured peers for the network layer, used for comparison on etcd errors.
  }
  deriving stock ((forall x. Environment -> Rep Environment x)
-> (forall x. Rep Environment x -> Environment)
-> Generic Environment
forall x. Rep Environment x -> Environment
forall x. Environment -> Rep Environment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Environment -> Rep Environment x
from :: forall x. Environment -> Rep Environment x
$cto :: forall x. Rep Environment x -> Environment
to :: forall x. Rep Environment x -> Environment
Generic, Environment -> Environment -> Bool
(Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool) -> Eq Environment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
/= :: Environment -> Environment -> Bool
Eq)

-- Stock-derived 'Show' would attempt to 'show' the 'Secret'-wrapped
-- 'signingKey' field, which is a 'TypeError'. The hand-rolled instance
-- below simply omits it.
instance Show Environment where
  show :: Environment -> String
show Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
$sel:depositActivation:Environment :: Environment -> DepositPeriod
depositActivation :: DepositPeriod
depositActivation, UnsyncedPeriod
$sel:unsyncedPeriod:Environment :: Environment -> UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
unsyncedPeriod, Text
$sel:configuredPeers:Environment :: Environment -> Text
configuredPeers :: Text
configuredPeers} =
    String
"Environment {party = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Party -> String
forall a. Show a => a -> String
show Party
party
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", signingKey = <Secret>, otherParties = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Party] -> String
forall a. Show a => a -> String
show [Party]
otherParties
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", participants = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [OnChainId] -> String
forall a. Show a => a -> String
show [OnChainId]
participants
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", contestationPeriod = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ContestationPeriod -> String
forall a. Show a => a -> String
show ContestationPeriod
contestationPeriod
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", depositPeriod = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DepositPeriod -> String
forall a. Show a => a -> String
show DepositPeriod
depositPeriod
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", depositActivation = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> DepositPeriod -> String
forall a. Show a => a -> String
show DepositPeriod
depositActivation
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", unsyncedPeriod = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnsyncedPeriod -> String
forall a. Show a => a -> String
show UnsyncedPeriod
unsyncedPeriod
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", configuredPeers = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
configuredPeers
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"

-- | 'ToJSON' deliberately omits 'signingKey' from the serialised output:
-- the WebSocket API sends 'Environment' to clients as part of 'Greetings',
-- and the signing key must never appear on the wire.
instance ToJSON Environment where
  toJSON :: Environment -> Value
toJSON Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
$sel:depositActivation:Environment :: Environment -> DepositPeriod
depositActivation :: DepositPeriod
depositActivation, UnsyncedPeriod
$sel:unsyncedPeriod:Environment :: Environment -> UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
unsyncedPeriod, Text
$sel:configuredPeers:Environment :: Environment -> Text
configuredPeers :: Text
configuredPeers} =
    [Pair] -> Value
object
      [ Key
"party" Key -> Party -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Party
party
      , Key
"otherParties" Key -> [Party] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Party]
otherParties
      , Key
"participants" Key -> [OnChainId] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [OnChainId]
participants
      , Key
"contestationPeriod" Key -> ContestationPeriod -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ContestationPeriod
contestationPeriod
      , Key
"depositPeriod" Key -> DepositPeriod -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DepositPeriod
depositPeriod
      , Key
"depositActivation" Key -> DepositPeriod -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DepositPeriod
depositActivation
      , Key
"unsyncedPeriod" Key -> UnsyncedPeriod -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UnsyncedPeriod
unsyncedPeriod
      , Key
"configuredPeers" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
configuredPeers
      ]

-- | 'FromJSON' is provided only so that types embedding 'Environment'
-- (e.g. 'Hydra.API.ServerOutput.Greetings') can still be parsed for
-- golden / roundtrip tests. The decoded signing key is a fixed
-- placeholder, NOT the real key: real signing keys must always be loaded
-- from disk via the text-envelope path. Tests that compare values for
-- equality should use the same placeholder via the 'Arbitrary' instance.
instance FromJSON Environment where
  parseJSON :: Value -> Parser Environment
parseJSON = String
-> (Object -> Parser Environment) -> Value -> Parser Environment
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Environment" ((Object -> Parser Environment) -> Value -> Parser Environment)
-> (Object -> Parser Environment) -> Value -> Parser Environment
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Party
-> Secret (SigningKey HydraKey)
-> [Party]
-> [OnChainId]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> UnsyncedPeriod
-> Text
-> Environment
Environment
      (Party
 -> Secret (SigningKey HydraKey)
 -> [Party]
 -> [OnChainId]
 -> ContestationPeriod
 -> DepositPeriod
 -> DepositPeriod
 -> UnsyncedPeriod
 -> Text
 -> Environment)
-> Parser Party
-> Parser
     (Secret (SigningKey HydraKey)
      -> [Party]
      -> [OnChainId]
      -> ContestationPeriod
      -> DepositPeriod
      -> DepositPeriod
      -> UnsyncedPeriod
      -> Text
      -> Environment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Party
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"party"
      Parser
  (Secret (SigningKey HydraKey)
   -> [Party]
   -> [OnChainId]
   -> ContestationPeriod
   -> DepositPeriod
   -> DepositPeriod
   -> UnsyncedPeriod
   -> Text
   -> Environment)
-> Parser (Secret (SigningKey HydraKey))
-> Parser
     ([Party]
      -> [OnChainId]
      -> ContestationPeriod
      -> DepositPeriod
      -> DepositPeriod
      -> UnsyncedPeriod
      -> Text
      -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Secret (SigningKey HydraKey)
-> Parser (Secret (SigningKey HydraKey))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Secret (SigningKey HydraKey)
placeholderSigningKey
      Parser
  ([Party]
   -> [OnChainId]
   -> ContestationPeriod
   -> DepositPeriod
   -> DepositPeriod
   -> UnsyncedPeriod
   -> Text
   -> Environment)
-> Parser [Party]
-> Parser
     ([OnChainId]
      -> ContestationPeriod
      -> DepositPeriod
      -> DepositPeriod
      -> UnsyncedPeriod
      -> Text
      -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Party]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"otherParties"
      Parser
  ([OnChainId]
   -> ContestationPeriod
   -> DepositPeriod
   -> DepositPeriod
   -> UnsyncedPeriod
   -> Text
   -> Environment)
-> Parser [OnChainId]
-> Parser
     (ContestationPeriod
      -> DepositPeriod
      -> DepositPeriod
      -> UnsyncedPeriod
      -> Text
      -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [OnChainId]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"participants"
      Parser
  (ContestationPeriod
   -> DepositPeriod
   -> DepositPeriod
   -> UnsyncedPeriod
   -> Text
   -> Environment)
-> Parser ContestationPeriod
-> Parser
     (DepositPeriod
      -> DepositPeriod -> UnsyncedPeriod -> Text -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser ContestationPeriod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contestationPeriod"
      Parser
  (DepositPeriod
   -> DepositPeriod -> UnsyncedPeriod -> Text -> Environment)
-> Parser DepositPeriod
-> Parser (DepositPeriod -> UnsyncedPeriod -> Text -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser DepositPeriod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depositPeriod"
      Parser (DepositPeriod -> UnsyncedPeriod -> Text -> Environment)
-> Parser DepositPeriod
-> Parser (UnsyncedPeriod -> Text -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser DepositPeriod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depositActivation"
      Parser (UnsyncedPeriod -> Text -> Environment)
-> Parser UnsyncedPeriod -> Parser (Text -> Environment)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser UnsyncedPeriod
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"unsyncedPeriod"
      Parser (Text -> Environment) -> Parser Text -> Parser Environment
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"configuredPeers"

-- | Like the JSON instance above, 'ToCBOR' deliberately omits 'signingKey'
-- (CBOR-encoding a 'Secret' is a compile-time error by design). This is why
-- the codec stays hand-written; the leading tag matches the generic format.
instance ToCBOR Environment where
  toCBOR :: Environment -> Encoding
toCBOR Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, [OnChainId]
$sel:participants:Environment :: Environment -> [OnChainId]
participants :: [OnChainId]
participants, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, DepositPeriod
$sel:depositActivation:Environment :: Environment -> DepositPeriod
depositActivation :: DepositPeriod
depositActivation, UnsyncedPeriod
$sel:unsyncedPeriod:Environment :: Environment -> UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
unsyncedPeriod, Text
$sel:configuredPeers:Environment :: Environment -> Text
configuredPeers :: Text
configuredPeers} =
    Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"Environment" :: Text)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Party -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Party
party
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Party] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [Party]
otherParties
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [OnChainId] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [OnChainId]
participants
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ContestationPeriod -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ContestationPeriod
contestationPeriod
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DepositPeriod -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DepositPeriod
depositPeriod
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DepositPeriod -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DepositPeriod
depositActivation
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UnsyncedPeriod -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UnsyncedPeriod
unsyncedPeriod
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Text
configuredPeers

-- | Like the JSON instance above, the decoded signing key is
-- 'placeholderSigningKey', NOT the real key.
instance FromCBOR Environment where
  fromCBOR :: forall s. Decoder s Environment
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s Environment) -> Decoder s Environment
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
"Environment" :: Text) -> do
        Party
party <- Decoder s Party
forall s. Decoder s Party
forall a s. FromCBOR a => Decoder s a
fromCBOR
        [Party]
otherParties <- Decoder s [Party]
forall s. Decoder s [Party]
forall a s. FromCBOR a => Decoder s a
fromCBOR
        [OnChainId]
participants <- Decoder s [OnChainId]
forall s. Decoder s [OnChainId]
forall a s. FromCBOR a => Decoder s a
fromCBOR
        ContestationPeriod
contestationPeriod <- Decoder s ContestationPeriod
forall s. Decoder s ContestationPeriod
forall a s. FromCBOR a => Decoder s a
fromCBOR
        DepositPeriod
depositPeriod <- Decoder s DepositPeriod
forall s. Decoder s DepositPeriod
forall a s. FromCBOR a => Decoder s a
fromCBOR
        DepositPeriod
depositActivation <- Decoder s DepositPeriod
forall s. Decoder s DepositPeriod
forall a s. FromCBOR a => Decoder s a
fromCBOR
        UnsyncedPeriod
unsyncedPeriod <- Decoder s UnsyncedPeriod
forall s. Decoder s UnsyncedPeriod
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Text
configuredPeers <- Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Environment -> Decoder s Environment
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          Environment
            { Party
$sel:party:Environment :: Party
party :: Party
party
            , $sel:signingKey:Environment :: Secret (SigningKey HydraKey)
signingKey = Secret (SigningKey HydraKey)
placeholderSigningKey
            , [Party]
$sel:otherParties:Environment :: [Party]
otherParties :: [Party]
otherParties
            , [OnChainId]
$sel:participants:Environment :: [OnChainId]
participants :: [OnChainId]
participants
            , ContestationPeriod
$sel:contestationPeriod:Environment :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
            , DepositPeriod
$sel:depositPeriod:Environment :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod
            , DepositPeriod
$sel:depositActivation:Environment :: DepositPeriod
depositActivation :: DepositPeriod
depositActivation
            , UnsyncedPeriod
$sel:unsyncedPeriod:Environment :: UnsyncedPeriod
unsyncedPeriod :: UnsyncedPeriod
unsyncedPeriod
            , Text
$sel:configuredPeers:Environment :: Text
configuredPeers :: Text
configuredPeers
            }
      Text
tag -> String -> Decoder s Environment
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Environment)
-> String -> Decoder s Environment
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded Environment"

-- | Sentinel signing key used when an 'Environment' has to be
-- reconstructed without access to the real one (e.g. JSON roundtrip
-- tests). Exported so 'Arbitrary' generators can use the same value,
-- keeping roundtrip 'Eq' stable.
placeholderSigningKey :: Secret (SigningKey HydraKey)
placeholderSigningKey :: Secret (SigningKey HydraKey)
placeholderSigningKey = ByteString -> Secret (SigningKey HydraKey)
generateSigningKey ByteString
"placeholder"

-- | Make 'HeadParameters' that are consistent with the given 'Environment'.
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters Environment{Party
$sel:party:Environment :: Environment -> Party
party :: Party
party, [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties :: [Party]
otherParties, ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Environment :: Environment -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} =
  HeadParameters{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, $sel:parties:HeadParameters :: [Party]
parties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties}