{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Cardano where

import Hydra.Prelude

import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Slot (EpochInfo)
import Cardano.Slotting.EpochInfo (hoistEpochInfo)
import Control.Monad.Trans.Except (runExcept)
import Hydra.Cardano.Api (
  EraHistory (EraHistory),
  Tx,
  toLedgerUTxO,
 )
import Hydra.Chain (ChainComponent, ChainStateHistory)
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.Blockfrost (BlockfrostBackend (..), withBlockfrostChain)
import Hydra.Chain.CardanoClient (
  QueryPoint (..),
 )
import Hydra.Chain.Direct (DirectBackend (..), withDirectChain)
import Hydra.Chain.Direct.Handlers (CardanoChainLog (..))
import Hydra.Chain.Direct.State (
  ChainContext (..),
 )
import Hydra.Chain.Direct.Wallet (
  TinyWallet (..),
  WalletInfoOnChain (..),
  newTinyWallet,
 )
import Hydra.Logging (Tracer)
import Hydra.Node.Util (readKeyPair)
import Hydra.Options (CardanoChainConfig (..), ChainBackendOptions (..))
import Hydra.Tx (Party)
import Ouroboros.Consensus.HardFork.History qualified as Consensus

withCardanoChain ::
  forall a.
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  Party ->
  -- | Chain state loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withCardanoChain :: forall a.
Tracer IO CardanoChainLog
-> CardanoChainConfig
-> Party
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withCardanoChain Tracer IO CardanoChainLog
tracer CardanoChainConfig
cfg Party
party ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action =
  case ChainBackendOptions
chainBackendOptions of
    Direct DirectOptions
directOptions -> do
      let directBackend :: DirectBackend
directBackend = DirectOptions -> DirectBackend
DirectBackend DirectOptions
directOptions
      TinyWallet IO
wallet <- DirectBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> IO (TinyWallet IO)
forall backend.
ChainBackend backend =>
backend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> IO (TinyWallet IO)
mkTinyWallet DirectBackend
directBackend Tracer IO CardanoChainLog
tracer CardanoChainConfig
cfg
      ChainContext
ctx <- DirectBackend -> CardanoChainConfig -> Party -> IO ChainContext
forall backend.
ChainBackend backend =>
backend -> CardanoChainConfig -> Party -> IO ChainContext
loadChainContext DirectBackend
directBackend CardanoChainConfig
cfg Party
party
      DirectBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
forall a.
DirectBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withDirectChain DirectBackend
directBackend Tracer IO CardanoChainLog
tracer CardanoChainConfig
cfg ChainContext
ctx TinyWallet IO
wallet ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action
    Blockfrost BlockfrostOptions
blockfrostOptions -> do
      let blockfrostBackend :: BlockfrostBackend
blockfrostBackend = BlockfrostOptions -> BlockfrostBackend
BlockfrostBackend BlockfrostOptions
blockfrostOptions
      TinyWallet IO
wallet <- BlockfrostBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> IO (TinyWallet IO)
forall backend.
ChainBackend backend =>
backend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> IO (TinyWallet IO)
mkTinyWallet BlockfrostBackend
blockfrostBackend Tracer IO CardanoChainLog
tracer CardanoChainConfig
cfg
      ChainContext
ctx <- BlockfrostBackend -> CardanoChainConfig -> Party -> IO ChainContext
forall backend.
ChainBackend backend =>
backend -> CardanoChainConfig -> Party -> IO ChainContext
loadChainContext BlockfrostBackend
blockfrostBackend CardanoChainConfig
cfg Party
party
      BlockfrostBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
forall a.
BlockfrostBackend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> ChainContext
-> TinyWallet IO
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withBlockfrostChain BlockfrostBackend
blockfrostBackend Tracer IO CardanoChainLog
tracer CardanoChainConfig
cfg ChainContext
ctx TinyWallet IO
wallet ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action
 where
  CardanoChainConfig{ChainBackendOptions
chainBackendOptions :: ChainBackendOptions
$sel:chainBackendOptions:CardanoChainConfig :: CardanoChainConfig -> ChainBackendOptions
chainBackendOptions} = CardanoChainConfig
cfg

-- | Build the 'ChainContext' from a 'ChainConfig' and additional information.
loadChainContext ::
  forall backend.
  ChainBackend backend =>
  backend ->
  CardanoChainConfig ->
  -- | Hydra party of our hydra node.
  Party ->
  -- | The current running era we can use to query the node
  IO ChainContext
loadChainContext :: forall backend.
ChainBackend backend =>
backend -> CardanoChainConfig -> Party -> IO ChainContext
loadChainContext backend
backend CardanoChainConfig
config Party
party = do
  (VerificationKey PaymentKey
vk, SigningKey PaymentKey
_) <- FilePath -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
readKeyPair FilePath
cardanoSigningKey
  ScriptRegistry
scriptRegistry <- backend -> [TxId] -> IO ScriptRegistry
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> [TxId] -> m ScriptRegistry
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> [TxId] -> m ScriptRegistry
queryScriptRegistry backend
backend [TxId]
hydraScriptsTxId
  NetworkId
networkId <- backend -> IO NetworkId
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m NetworkId
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m NetworkId
queryNetworkId backend
backend
  ChainContext -> IO ChainContext
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext -> IO ChainContext)
-> ChainContext -> IO ChainContext
forall a b. (a -> b) -> a -> b
$
    ChainContext
      { NetworkId
networkId :: NetworkId
$sel:networkId:ChainContext :: NetworkId
networkId
      , $sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey = VerificationKey PaymentKey
vk
      , $sel:ownParty:ChainContext :: Party
ownParty = Party
party
      , ScriptRegistry
scriptRegistry :: ScriptRegistry
$sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry
      }
 where
  CardanoChainConfig
    { [TxId]
hydraScriptsTxId :: [TxId]
$sel:hydraScriptsTxId:CardanoChainConfig :: CardanoChainConfig -> [TxId]
hydraScriptsTxId
    , FilePath
cardanoSigningKey :: FilePath
$sel:cardanoSigningKey:CardanoChainConfig :: CardanoChainConfig -> FilePath
cardanoSigningKey
    } = CardanoChainConfig
config

mkTinyWallet ::
  forall backend.
  ChainBackend backend =>
  backend ->
  Tracer IO CardanoChainLog ->
  CardanoChainConfig ->
  IO (TinyWallet IO)
mkTinyWallet :: forall backend.
ChainBackend backend =>
backend
-> Tracer IO CardanoChainLog
-> CardanoChainConfig
-> IO (TinyWallet IO)
mkTinyWallet backend
backend Tracer IO CardanoChainLog
tracer CardanoChainConfig
config = do
  (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair <- FilePath -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
readKeyPair FilePath
cardanoSigningKey
  NetworkId
networkId <- backend -> IO NetworkId
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m NetworkId
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m NetworkId
queryNetworkId backend
backend
  Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet ((TinyWalletLog -> CardanoChainLog)
-> Tracer IO CardanoChainLog -> Tracer IO TinyWalletLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TinyWalletLog -> CardanoChainLog
Wallet Tracer IO CardanoChainLog
tracer) NetworkId
networkId (VerificationKey PaymentKey, SigningKey PaymentKey)
keyPair ChainQuery IO
queryWalletInfo IO (EpochInfo (Either Text))
queryEpochInfo IO (PParams ConwayEra)
IO (PParams LedgerEra)
querySomePParams
 where
  CardanoChainConfig{FilePath
$sel:cardanoSigningKey:CardanoChainConfig :: CardanoChainConfig -> FilePath
cardanoSigningKey :: FilePath
cardanoSigningKey} = CardanoChainConfig
config

  queryEpochInfo :: IO (EpochInfo (Either Text))
queryEpochInfo = EraHistory -> EpochInfo (Either Text)
toEpochInfo (EraHistory -> EpochInfo (Either Text))
-> IO EraHistory -> IO (EpochInfo (Either Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> backend -> QueryPoint -> IO EraHistory
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m EraHistory
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m EraHistory
queryEraHistory backend
backend QueryPoint
QueryTip

  querySomePParams :: IO (PParams LedgerEra)
querySomePParams = backend -> QueryPoint -> IO (PParams LedgerEra)
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters backend
backend QueryPoint
QueryTip
  queryWalletInfo :: ChainQuery IO
queryWalletInfo QueryPoint
queryPoint Address ShelleyAddr
address = do
    ChainPoint
point <- case QueryPoint
queryPoint of
      QueryAt ChainPoint
point -> ChainPoint -> IO ChainPoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainPoint
point
      QueryPoint
QueryTip -> backend -> IO ChainPoint
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m ChainPoint
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m ChainPoint
queryTip backend
backend
    Map TxIn (TxOut ConwayEra)
walletUTxO <- UTxO ConwayEra -> Map TxIn (TxOut ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut era)
Ledger.unUTxO (UTxO ConwayEra -> Map TxIn (TxOut ConwayEra))
-> (UTxO -> UTxO ConwayEra) -> UTxO -> Map TxIn (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO ConwayEra
UTxO -> UTxO LedgerEra
toLedgerUTxO (UTxO -> Map TxIn (TxOut ConwayEra))
-> IO UTxO -> IO (Map TxIn (TxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> backend -> [Address ShelleyAddr] -> IO UTxO
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> [Address ShelleyAddr] -> m UTxO
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> [Address ShelleyAddr] -> m UTxO
queryUTxO backend
backend [Address ShelleyAddr
address]
    SystemStart
systemStart <- backend -> QueryPoint -> IO SystemStart
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m SystemStart
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m SystemStart
querySystemStart backend
backend QueryPoint
QueryTip
    WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$ WalletInfoOnChain{Map TxIn (TxOut ConwayEra)
Map TxIn TxOut
walletUTxO :: Map TxIn (TxOut ConwayEra)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO, SystemStart
systemStart :: SystemStart
$sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart, $sel:tip:WalletInfoOnChain :: ChainPoint
tip = ChainPoint
point}

  toEpochInfo :: EraHistory -> EpochInfo (Either Text)
  toEpochInfo :: EraHistory -> EpochInfo (Either Text)
toEpochInfo (EraHistory Interpreter xs
interpreter) =
    (forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
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 PastHorizonException -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) (EpochInfo (Except PastHorizonException)
 -> EpochInfo (Either Text))
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall a b. (a -> b) -> a -> b
$
      Interpreter xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (Except PastHorizonException)
Consensus.interpreterToEpochInfo Interpreter xs
interpreter