-- | 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 (
  AsType (AsPaymentKey, AsSigningKey),
  HasTypeProxy (AsType),
  Key (VerificationKey, getVerificationKey),
  NetworkId,
  PaymentKey,
  SigningKey,
  SocketPath,
  TextEnvelopeError (TextEnvelopeAesonDecodeError),
  TxId,
  deserialiseFromTextEnvelope,
  textEnvelopeToJSON,
 )
import Hydra.Cluster.Fixture (Actor, actorName, fundsOf)
import Hydra.ContestationPeriod (ContestationPeriod)
import Hydra.Ledger.Cardano (genSigningKey)
import Hydra.Options (ChainConfig (..), DirectChainConfig (..), defaultDirectChainConfig)
import Paths_hydra_cluster qualified as Pkg
import System.FilePath ((<.>), (</>))
import Test.Hydra.Prelude (failure)
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.
keysFor :: Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor :: Actor -> IO (VerificationKey PaymentKey, 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
>>= AsType (SigningKey PaymentKey)
-> TextEnvelope -> Either TextEnvelopeError (SigningKey PaymentKey)
forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope AsType (SigningKey PaymentKey)
asSigningKey
  case Either TextEnvelopeError (SigningKey PaymentKey)
res of
    Left TextEnvelopeError
err ->
      String -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> String -> IO (VerificationKey PaymentKey, 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, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, 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
sk)
 where
  asSigningKey :: AsType (SigningKey PaymentKey)
  asSigningKey :: AsType (SigningKey PaymentKey)
asSigningKey = AsType PaymentKey -> AsType (SigningKey PaymentKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType PaymentKey
AsPaymentKey

-- | Create and save new signing key at the provided path.
-- NOTE: Uses 'TextEnvelope' format.
createAndSaveSigningKey :: FilePath -> IO (SigningKey PaymentKey)
createAndSaveSigningKey :: String -> IO (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
  SigningKey PaymentKey -> IO (SigningKey PaymentKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SigningKey PaymentKey
sk

chainConfigFor ::
  HasCallStack =>
  Actor ->
  FilePath ->
  SocketPath ->
  -- | Transaction id at which Hydra scripts should have been published.
  TxId ->
  [Actor] ->
  ContestationPeriod ->
  IO ChainConfig
chainConfigFor :: HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
me String
targetDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor]
them ContestationPeriod
contestationPeriod = 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
$
    DirectChainConfig -> ChainConfig
Direct
      DirectChainConfig
defaultDirectChainConfig
        { nodeSocket
        , hydraScriptsTxId
        , cardanoSigningKey = actorFilePath me "sk"
        , cardanoVerificationKeys = [actorFilePath himOrHer "vk" | himOrHer <- them]
        , contestationPeriod
        }
 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 :: (DirectChainConfig -> DirectChainConfig) -> ChainConfig -> ChainConfig
modifyConfig :: (DirectChainConfig -> DirectChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig DirectChainConfig -> DirectChainConfig
fn = \case
  Direct DirectChainConfig
config -> DirectChainConfig -> ChainConfig
Direct (DirectChainConfig -> ChainConfig)
-> DirectChainConfig -> ChainConfig
forall a b. (a -> b) -> a -> b
$ DirectChainConfig -> DirectChainConfig
fn DirectChainConfig
config
  ChainConfig
x -> ChainConfig
x

setNetworkId :: NetworkId -> ChainConfig -> ChainConfig
setNetworkId :: NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId = \case
  Direct DirectChainConfig
config -> DirectChainConfig -> ChainConfig
Direct DirectChainConfig
config{networkId}
  ChainConfig
x -> ChainConfig
x