module Hydra.Chain.Offline where

import Hydra.Prelude

import Cardano.Api.Genesis (shelleyGenesisDefaults)
import Cardano.Api.GenesisParameters (fromShelleyGenesis)
import Cardano.Ledger.Slot (unSlotNo)
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 Hydra.Cardano.Api (GenesisParameters (..), ShelleyEra, ShelleyGenesis (..), StandardCrypto, Tx)
import Hydra.Chain (
  Chain (..),
  ChainComponent,
  ChainEvent (..),
  ChainStateHistory,
  OnChainTx (..),
  PostTxError (..),
  chainSlot,
  chainTime,
  initHistory,
 )
import Hydra.Chain.ChainState (ChainSlot (ChainSlot))
import Hydra.Chain.Direct.State (initialChainState)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime, slotNoToUTCTime)
import Hydra.Network (NodeId (nodeId))
import Hydra.Options (OfflineChainConfig (..), defaultContestationPeriod)
import Hydra.Tx (HeadId (..), HeadParameters (..), HeadSeed (..), Party)
import Hydra.Utils (readJsonFileThrow)

-- | Derived 'HeadId' of offline head.
offlineHeadId :: NodeId -> HeadId
offlineHeadId :: NodeId -> HeadId
offlineHeadId = ByteString -> HeadId
UnsafeHeadId (ByteString -> HeadId)
-> (NodeId -> ByteString) -> NodeId -> HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"offline-" <>) (ByteString -> ByteString)
-> (NodeId -> ByteString) -> NodeId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> (NodeId -> Text) -> NodeId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeId -> Text
nodeId

-- | Derived 'HeadSeed' of offline head.
offlineHeadSeed :: NodeId -> HeadSeed
offlineHeadSeed :: NodeId -> HeadSeed
offlineHeadSeed = ByteString -> HeadSeed
UnsafeHeadSeed (ByteString -> HeadSeed)
-> (NodeId -> ByteString) -> NodeId -> HeadSeed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"offline-" <>) (ByteString -> ByteString)
-> (NodeId -> ByteString) -> NodeId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> (NodeId -> Text) -> NodeId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeId -> Text
nodeId

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 =
  -- TODO: uses internal cardano-api lib
  ShelleyGenesis StandardCrypto -> GenesisParameters ShelleyEra
fromShelleyGenesis
    (ShelleyGenesis StandardCrypto -> GenesisParameters ShelleyEra)
-> IO (ShelleyGenesis StandardCrypto)
-> 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
        -- TODO: uses internal cardano-api lib
        ShelleyGenesis StandardCrypto -> IO (ShelleyGenesis StandardCrypto)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis StandardCrypto
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 StandardCrypto))
-> Value -> Either String (ShelleyGenesis StandardCrypto)
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.parseEither (forall a. FromJSON a => Value -> Parser a
parseJSON @(ShelleyGenesis StandardCrypto)) Value
jsonVal of
          Right ShelleyGenesis StandardCrypto
a -> ShelleyGenesis StandardCrypto -> IO (ShelleyGenesis StandardCrypto)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGenesis StandardCrypto
a
          Left String
e -> InitialUTxOParseException -> IO (ShelleyGenesis StandardCrypto)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InitialUTxOParseException -> IO (ShelleyGenesis StandardCrypto))
-> InitialUTxOParseException -> IO (ShelleyGenesis StandardCrypto)
forall a b. (a -> b) -> a -> b
$ String -> InitialUTxOParseException
InitialUTxOParseException String
e

withOfflineChain ::
  NodeId ->
  OfflineChainConfig ->
  Party ->
  -- | Last known chain state as loaded from persistence.
  ChainStateHistory Tx ->
  ChainComponent Tx IO a
withOfflineChain :: forall a.
NodeId
-> OfflineChainConfig
-> Party
-> ChainStateHistory Tx
-> ChainComponent Tx IO a
withOfflineChain NodeId
nodeId OfflineChainConfig{Maybe String
ledgerGenesisFile :: Maybe String
$sel:ledgerGenesisFile:OfflineChainConfig :: OfflineChainConfig -> Maybe String
ledgerGenesisFile, String
initialUTxOFile :: String
$sel:initialUTxOFile:OfflineChainConfig :: OfflineChainConfig -> String
initialUTxOFile} Party
party 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
  IO () -> (Async IO () -> IO a) -> IO a
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (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
forall {tx} {m :: * -> *}. Chain tx m
chainHandle
 where
  headId :: HeadId
headId = NodeId -> HeadId
offlineHeadId NodeId
nodeId

  chainHandle :: Chain tx m
chainHandle =
    Chain
      { $sel:submitTx:Chain :: MonadThrow m => tx -> m ()
submitTx = m () -> tx -> m ()
forall a b. a -> b -> a
const (m () -> tx -> m ()) -> m () -> tx -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , $sel:draftCommitTx:Chain :: MonadThrow m =>
HeadId -> CommitBlueprintTx tx -> m (Either (PostTxError tx) tx)
draftCommitTx = \HeadId
_ CommitBlueprintTx tx
_ -> Either (PostTxError tx) tx -> m (Either (PostTxError tx) tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError tx) tx -> m (Either (PostTxError tx) tx))
-> Either (PostTxError tx) tx -> m (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 PostTxError tx
forall tx. PostTxError tx
FailedToDraftTxNotInitializing
      , $sel:draftDepositTx:Chain :: MonadThrow m =>
HeadId
-> CommitBlueprintTx tx
-> UTCTime
-> m (Either (PostTxError tx) tx)
draftDepositTx = \HeadId
_ CommitBlueprintTx tx
_ UTCTime
_ -> Either (PostTxError tx) tx -> m (Either (PostTxError tx) tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError tx) tx -> m (Either (PostTxError tx) tx))
-> Either (PostTxError tx) tx -> m (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 PostTxError tx
forall tx. PostTxError tx
FailedToConstructDepositTx
      , $sel:postTx:Chain :: MonadThrow m => PostChainTx tx -> m ()
postTx = m () -> PostChainTx tx -> m ()
forall a b. a -> b -> a
const (m () -> PostChainTx tx -> m ()) -> m () -> PostChainTx tx -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }

  initializeOfflineHead :: IO ()
initializeOfflineHead = do
    let emptyChainStateHistory :: ChainStateHistory Tx
emptyChainStateHistory = ChainStateType Tx -> ChainStateHistory Tx
forall 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
      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

      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
                , $sel:headSeed:OnInitTx :: HeadSeed
headSeed = NodeId -> HeadSeed
offlineHeadSeed NodeId
nodeId
                , $sel:headParameters:OnInitTx :: HeadParameters
headParameters =
                    HeadParameters
                      { $sel:parties:HeadParameters :: [Party]
parties = [Party
party]
                      , -- NOTE: This is irrelevant in offline mode.
                        $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
defaultContestationPeriod
                      }
                , $sel:participants:OnInitTx :: [OnChainId]
participants = []
                }
          }
      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 =
              OnCommitTx
                { Party
party :: Party
$sel:party:OnInitTx :: Party
party
                , $sel:committed:OnInitTx :: UTxOType Tx
committed = UTxOType Tx
UTxO
initialUTxO
                , HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
                }
          }
      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 = OnCollectComTx{HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId}
          }

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
    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:chainSlot:Observation :: ChainSlot
chainSlot = Natural -> ChainSlot
ChainSlot (Natural -> ChainSlot)
-> (Word64 -> Natural) -> Word64 -> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> ChainSlot) -> Word64 -> ChainSlot
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
upcomingSlot
        }
  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