module Hydra.Chain.Offline where

import Hydra.Prelude

import Cardano.Api.Genesis (fromShelleyGenesis, shelleyGenesisDefaults)
import Cardano.Slotting.Time (SystemStart (SystemStart), mkSlotLength)
import Control.Monad.Class.MonadAsync (link)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.ByteString qualified as BS
import Hydra.Cardano.Api (
  AsType (..),
  BlockHeader,
  ChainPoint (..),
  GenesisParameters (..),
  Hash,
  SerialiseAsRawBytes (deserialiseFromRawBytes),
  ShelleyEra,
  ShelleyGenesis (..),
  Tx,
  unsafeBlockHeaderHashFromBytes,
 )
import Hydra.Chain (
  Chain (..),
  ChainComponent,
  ChainEvent (..),
  ChainStateHistory,
  OnChainTx (..),
  PostChainTx (..),
  PostTxError (..),
  chainTime,
  initHistory,
 )
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime, slotNoToUTCTime)
import Hydra.Node.Util (checkNonADAAssetsUTxO)
import Hydra.Options (OfflineChainConfig (..), defaultContestationPeriod, defaultDepositPeriod)
import Hydra.Tx (HeadId (..), HeadParameters (..), HeadSeed (..), Party, Snapshot (..), getSnapshot, snapshotUTxO)
import Hydra.Tx.DepositPeriod (DepositPeriod (..))
import Hydra.Utils (readJsonFileThrow)

-- | Derived 'HeadId' of offline head from a 'HeadSeed'.
offlineHeadId :: HeadSeed -> HeadId
offlineHeadId :: HeadSeed -> HeadId
offlineHeadId (UnsafeHeadSeed ByteString
seed) = ByteString -> HeadId
UnsafeHeadId (ByteString -> HeadId) -> ByteString -> HeadId
forall a b. (a -> b) -> a -> b
$ ByteString
"offline-" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
seed

newtype InitialUTxOParseException = InitialUTxOParseException String
  deriving stock (Int -> InitialUTxOParseException -> ShowS
[InitialUTxOParseException] -> ShowS
InitialUTxOParseException -> String
(Int -> InitialUTxOParseException -> ShowS)
-> (InitialUTxOParseException -> String)
-> ([InitialUTxOParseException] -> ShowS)
-> Show InitialUTxOParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialUTxOParseException -> ShowS
showsPrec :: Int -> InitialUTxOParseException -> ShowS
$cshow :: InitialUTxOParseException -> String
show :: InitialUTxOParseException -> String
$cshowList :: [InitialUTxOParseException] -> ShowS
showList :: [InitialUTxOParseException] -> ShowS
Show)

instance Exception InitialUTxOParseException where
  displayException :: InitialUTxOParseException -> String
displayException (InitialUTxOParseException String
err) =
    String
"Failed to parse initial UTXO: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". Example UTXO: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"{\"1541287c2598ffc682742c961a96343ac64e9b9030e6b03a476bb18c8c50134d#0\":{\"address\":\"addr_test1vqg9ywrpx6e50uam03nlu0ewunh3yrscxmjayurmkp52lfskgkq5k\",\"datum\":null,\"datumhash\":null,\"inlineDatum \":null,\"referenceScript\":null,\"value\":{\"lovelace\":100000000}},\"39786f186d94d8dd0b4fcf05d1458b18cd5fd8c6823364612f4a3c11b77e7cc7#0\":{\"address\":\"addr_test1vru2drx33ev6dt8gfq245r5k0tmy7ngqe79va69de9dxkrg09c7d3\",\"datum\":null,\"datumhash\":null,\"inlineDatum\":null,\"referenceScript\":null,\"value\":{\"lovelace\":100000000}}}"

-- | Load the given genesis file or use defaults specific to the offline mode.
-- Throws: 'InitialUTxOParseException' if the initial UTXO file could not be parsed.
loadGenesisFile :: Maybe FilePath -> IO (GenesisParameters ShelleyEra)
loadGenesisFile :: Maybe String -> IO (GenesisParameters ShelleyEra)
loadGenesisFile Maybe String
ledgerGenesisFile =
  HasCallStack => ShelleyGenesis -> GenesisParameters ShelleyEra
ShelleyGenesis -> GenesisParameters ShelleyEra
fromShelleyGenesis
    (ShelleyGenesis -> GenesisParameters ShelleyEra)
-> IO ShelleyGenesis -> IO (GenesisParameters ShelleyEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe String
ledgerGenesisFile of
      Maybe String
Nothing -> do
        UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        ShelleyGenesis -> IO ShelleyGenesis
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis
shelleyGenesisDefaults{sgSystemStart = now}
      Just String
fp -> do
        Value
jsonVal <- String -> IO (Either String Value)
forall a. FromJSON a => String -> IO (Either String a)
Aeson.eitherDecodeFileStrict String
fp IO (Either String Value)
-> (Either String Value -> IO Value) -> IO Value
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Value)
-> (Value -> IO Value) -> Either String Value -> IO Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Value
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure -- just crash if we can't read the file
        case (Value -> Parser ShelleyGenesis)
-> Value -> Either String ShelleyGenesis
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.parseEither (forall a. FromJSON a => Value -> Parser a
parseJSON @ShelleyGenesis) Value
jsonVal of
          Right ShelleyGenesis
a -> ShelleyGenesis -> IO ShelleyGenesis
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis
a
          Left String
e -> InitialUTxOParseException -> IO ShelleyGenesis
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InitialUTxOParseException -> IO ShelleyGenesis)
-> InitialUTxOParseException -> IO ShelleyGenesis
forall a b. (a -> b) -> a -> b
$ String -> InitialUTxOParseException
InitialUTxOParseException String
e

withOfflineChain ::
  OfflineChainConfig ->
  Party ->
  [Party] ->
  -- | Last known chain state as loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withOfflineChain :: forall a.
OfflineChainConfig
-> Party
-> [Party]
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withOfflineChain OfflineChainConfig
config Party
party [Party]
otherParties ChainStateHistory Tx
chainStateHistory ChainCallback Tx IO
callback Chain Tx IO -> IO a
action = do
  IO ()
initializeOfflineHead
  GenesisParameters ShelleyEra
genesis <- Maybe String -> IO (GenesisParameters ShelleyEra)
loadGenesisFile Maybe String
ledgerGenesisFile
  (String, IO ()) -> (Async IO () -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"offline-chain-tickForever", GenesisParameters ShelleyEra -> ChainCallback Tx IO -> IO ()
tickForever GenesisParameters ShelleyEra
genesis ChainCallback Tx IO
callback) ((Async IO () -> IO a) -> IO a) -> (Async IO () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async IO ()
tickThread -> do
    Async IO () -> IO ()
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m) =>
Async m a -> m ()
link Async IO ()
tickThread
    Chain Tx IO -> IO a
action Chain Tx IO
chainHandle
 where
  OfflineChainConfig
    { $sel:offlineHeadSeed:OfflineChainConfig :: OfflineChainConfig -> HeadSeed
offlineHeadSeed = HeadSeed
headSeed
    , String
initialUTxOFile :: String
$sel:initialUTxOFile:OfflineChainConfig :: OfflineChainConfig -> String
initialUTxOFile
    , Maybe String
ledgerGenesisFile :: Maybe String
$sel:ledgerGenesisFile:OfflineChainConfig :: OfflineChainConfig -> Maybe String
ledgerGenesisFile
    } = OfflineChainConfig
config

  headId :: HeadId
headId = HeadSeed -> HeadId
offlineHeadId HeadSeed
headSeed

  chainHandle :: Chain Tx IO
  chainHandle :: Chain Tx IO
chainHandle =
    Chain
      { $sel:submitTx:Chain :: MonadThrow IO => Tx -> IO ()
submitTx = IO () -> Tx -> IO ()
forall a b. a -> b -> a
const (IO () -> Tx -> IO ()) -> IO () -> Tx -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , $sel:draftDepositTx:Chain :: MonadThrow IO =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> IO (Either (PostTxError Tx) Tx)
draftDepositTx = \HeadId
_ PParams LedgerEra
_ ConfirmedSnapshot Tx
_ CommitBlueprintTx Tx
_ UTCTime
_ Maybe AddressInEra
_ -> Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> IO (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$ PostTxError Tx -> Either (PostTxError Tx) Tx
forall a b. a -> Either a b
Left FailedToConstructDepositTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
"not implemented"}
      , $sel:postTx:Chain :: MonadThrow IO => PostChainTx Tx -> IO ()
postTx = \case
          -- Simulate on-chain confirmation of increment by immediately emitting
          -- OnIncrementTx. This allows the offline head to go through the full
          -- deposit snapshot flow
          IncrementTx{TxIdType Tx
depositTxId :: TxIdType Tx
$sel:depositTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
depositTxId, ConfirmedSnapshot Tx
incrementingSnapshot :: ConfirmedSnapshot Tx
$sel:incrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot} ->
            ChainCallback Tx IO
callback ChainCallback Tx IO -> ChainCallback Tx IO
forall a b. (a -> b) -> a -> b
$
              Observation
                { $sel:newChainState:Observation :: ChainStateType Tx
newChainState = ChainStateType Tx
initialChainState
                , $sel:observedTx:Observation :: OnChainTx Tx
observedTx =
                    OnIncrementTx
                      { HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
                      , $sel:newVersion:OnInitTx :: SnapshotVersion
newVersion = Snapshot Tx -> SnapshotVersion
forall tx. Snapshot tx -> SnapshotVersion
version (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
incrementingSnapshot) SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
                      , TxIdType Tx
depositTxId :: TxIdType Tx
$sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId
                      }
                }
          PostChainTx Tx
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , $sel:checkNonADAAssets:Chain :: ConfirmedSnapshot Tx -> Either Value ()
checkNonADAAssets = UTxO -> Either Value ()
checkNonADAAssetsUTxO (UTxO -> Either Value ())
-> (ConfirmedSnapshot Tx -> UTxO)
-> ConfirmedSnapshot Tx
-> Either Value ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot Tx -> UTxOType Tx
Snapshot Tx -> UTxO
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO (Snapshot Tx -> UTxO)
-> (ConfirmedSnapshot Tx -> Snapshot Tx)
-> ConfirmedSnapshot Tx
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot
      }

  initializeOfflineHead :: IO ()
initializeOfflineHead = do
    let emptyChainStateHistory :: ChainStateHistory Tx
emptyChainStateHistory = ChainStateType Tx -> ChainStateHistory Tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType Tx
initialChainState

    -- if we don't have a chainStateHistory to restore from disk from, start a new one
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChainStateHistory Tx
chainStateHistory ChainStateHistory Tx -> ChainStateHistory Tx -> Bool
forall a. Eq a => a -> a -> Bool
== ChainStateHistory Tx
emptyChainStateHistory) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ChainCallback Tx IO
callback ChainCallback Tx IO -> ChainCallback Tx IO
forall a b. (a -> b) -> a -> b
$
        Observation
          { $sel:newChainState:Observation :: ChainStateType Tx
newChainState = ChainStateType Tx
initialChainState
          , $sel:observedTx:Observation :: OnChainTx Tx
observedTx =
              OnInitTx
                { HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
                , HeadSeed
headSeed :: HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed
                , $sel:headParameters:OnInitTx :: HeadParameters
headParameters =
                    HeadParameters
                      { $sel:parties:HeadParameters :: [Party]
parties = [Party] -> [Party]
forall a. Ord a => [a] -> [a]
sort (Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties)
                      , -- NOTE: These are irrelevant in offline mode.
                        $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
                      , $sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod
                      }
                , $sel:participants:OnInitTx :: [OnChainId]
participants = []
                }
          }

      UTxO
initialUTxO <- (Value -> Parser UTxO) -> String -> IO UTxO
forall a. (Value -> Parser a) -> String -> IO a
readJsonFileThrow Value -> Parser UTxO
forall a. FromJSON a => Value -> Parser a
parseJSON String
initialUTxOFile
      TxId
depositTxId <- case AsType TxId -> ByteString -> Either SerialiseAsRawBytesError TxId
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes AsType TxId
AsTxId (ByteString -> Either SerialiseAsRawBytesError TxId)
-> ByteString -> Either SerialiseAsRawBytesError TxId
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0 of
        Left SerialiseAsRawBytesError
e -> Text -> IO TxId
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO TxId) -> Text -> IO TxId
forall a b. (a -> b) -> a -> b
$ Text
"Failed to mock offline deposit: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SerialiseAsRawBytesError -> Text
forall b a. (Show a, IsString b) => a -> b
show SerialiseAsRawBytesError
e
        Right TxId
x -> TxId -> IO TxId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxId
x
      -- Set timestamps so the deposit is immediately Active on the first chain
      -- tick. The deposit period used by HeadLogic is 'defaultDepositPeriod'
      -- (because no override via OfflineChainConfig).
      UTCTime
now <- IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      let depositBuffer :: NominalDiffTime
depositBuffer = NominalDiffTime
2 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* DepositPeriod -> NominalDiffTime
toNominalDiffTime DepositPeriod
defaultDepositPeriod
      ChainCallback Tx IO
callback ChainCallback Tx IO -> ChainCallback Tx IO
forall a b. (a -> b) -> a -> b
$
        Observation
          { $sel:newChainState:Observation :: ChainStateType Tx
newChainState = ChainStateType Tx
initialChainState
          , $sel:observedTx:Observation :: OnChainTx Tx
observedTx =
              OnDepositTx
                { HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
                , TxIdType Tx
TxId
$sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId :: TxId
depositTxId
                , $sel:deposited:OnInitTx :: UTxOType Tx
deposited = UTxOType Tx
UTxO
initialUTxO
                , $sel:created:OnInitTx :: UTCTime
created = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
depositBuffer) UTCTime
now
                , $sel:deadline:OnInitTx :: UTCTime
deadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
depositBuffer UTCTime
now
                }
          }

-- | Continuously produces offline chain ticks according to wall-clock time.
-- Each tick is aligned with the expected slot time, ensuring the node
-- state stays synchronized with the offline chain.
-- This prevents the node from violating the configured unsynced period
-- which guarantees that client and network inputs are always processed safely.
tickForever :: GenesisParameters ShelleyEra -> (ChainEvent Tx -> IO ()) -> IO ()
tickForever :: GenesisParameters ShelleyEra -> ChainCallback Tx IO -> IO ()
tickForever GenesisParameters ShelleyEra
genesis ChainCallback Tx IO
callback = do
  SlotNo
initialSlot <- SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength (UTCTime -> SlotNo) -> IO UTCTime -> IO SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
  (SlotNo -> IO ()) -> [SlotNo] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ SlotNo -> IO ()
nextTick [SlotNo
initialSlot ..]
 where
  nextTick :: SlotNo -> IO ()
nextTick SlotNo
upcomingSlot = do
    let timeToSleepUntil :: UTCTime
timeToSleepUntil = SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
upcomingSlot
    NominalDiffTime
sleepDelay <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
timeToSleepUntil (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
sleepDelay
    let point :: ChainPoint
point = SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
upcomingSlot Hash BlockHeader
offlineBlockHash
    ChainCallback Tx IO
callback ChainCallback Tx IO -> ChainCallback Tx IO
forall a b. (a -> b) -> a -> b
$
      Tick
        { $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
timeToSleepUntil
        , $sel:chainPoint:Observation :: ChainPointType Tx
chainPoint = ChainPoint
ChainPointType Tx
point
        }
  systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart UTCTime
protocolParamSystemStart

  slotLength :: SlotLength
slotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
protocolParamSlotLength

  GenesisParameters
    { NominalDiffTime
protocolParamSlotLength :: NominalDiffTime
protocolParamSlotLength :: forall era. GenesisParameters era -> NominalDiffTime
protocolParamSlotLength
    , UTCTime
protocolParamSystemStart :: UTCTime
protocolParamSystemStart :: forall era. GenesisParameters era -> UTCTime
protocolParamSystemStart
    } = GenesisParameters ShelleyEra
genesis

offlineBlockHash :: Hash BlockHeader
offlineBlockHash :: Hash BlockHeader
offlineBlockHash = HasCallStack => ByteString -> Hash BlockHeader
ByteString -> Hash BlockHeader
unsafeBlockHeaderHashFromBytes ByteString
"offline-blockhash-00000000000000"