{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}
module Hydra.Chain.Direct.Handlers where
import Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Concurrent.Class.MonadSTM (modifyTVar, newTVarIO, writeTVar)
import Control.Monad.Class.MonadSTM (throwSTM)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Hydra.Cardano.Api (
BlockHeader,
ChainPoint (..),
Tx,
TxId,
chainPointToSlotNo,
fromLedgerTxIn,
getChainPoint,
getTxBody,
getTxId,
)
import Hydra.Chain (
Chain (..),
ChainCallback,
ChainEvent (..),
ChainStateHistory,
ChainStateType,
HeadParameters (..),
IsChainState,
OnChainTx (..),
PostChainTx (..),
PostTxError (..),
currentState,
pushNewState,
rollbackHistory,
)
import Hydra.Chain.Direct.State (
ChainContext (..),
ChainStateAt (..),
abort,
chainSlotFromPoint,
close,
collect,
commit',
contest,
fanout,
getKnownUTxO,
initialize,
)
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..))
import Hydra.Chain.Direct.Tx (
AbortObservation (..),
CloseObservation (..),
ClosedThreadOutput (..),
CollectComObservation (..),
CommitObservation (..),
ContestObservation (..),
FanoutObservation (..),
HeadObservation (..),
InitObservation (..),
headSeedToTxIn,
observeHeadTx,
txInToHeadSeed,
)
import Hydra.Chain.Direct.Wallet (
ErrCoverFee (..),
TinyWallet (..),
TinyWalletLog,
)
import Hydra.ContestationPeriod (toNominalDiffTime)
import Hydra.Ledger (ChainSlot (ChainSlot), UTxOType)
import Hydra.Ledger.Cardano (adjustUTxO)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Plutus.Orphans ()
import System.IO.Error (userError)
data LocalChainState m tx = LocalChainState
{ forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType tx)
, forall (m :: * -> *) tx.
LocalChainState m tx -> ChainStateType tx -> STM m ()
pushNew :: ChainStateType tx -> STM m ()
, forall (m :: * -> *) tx.
LocalChainState m tx -> ChainSlot -> STM m (ChainStateType tx)
rollback :: ChainSlot -> STM m (ChainStateType tx)
, forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateHistory tx)
history :: STM m (ChainStateHistory tx)
}
newLocalChainState ::
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx ->
m (LocalChainState m tx)
newLocalChainState :: forall (m :: * -> *) tx.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory tx
chainState = do
TVar m (ChainStateHistory tx)
tv <- ChainStateHistory tx -> m (TVar m (ChainStateHistory tx))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO ChainStateHistory tx
chainState
LocalChainState m tx -> m (LocalChainState m tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
LocalChainState
{ $sel:getLatest:LocalChainState :: STM m (ChainStateType tx)
getLatest = TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
forall {m :: * -> *} {tx}.
MonadSTM m =>
TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
getLatest TVar m (ChainStateHistory tx)
tv
, $sel:pushNew:LocalChainState :: ChainStateType tx -> STM m ()
pushNew = TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
forall {m :: * -> *} {tx}.
MonadSTM m =>
TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
pushNew TVar m (ChainStateHistory tx)
tv
, $sel:rollback:LocalChainState :: ChainSlot -> STM m (ChainStateType tx)
rollback = TVar m (ChainStateHistory tx)
-> ChainSlot -> STM m (ChainStateType tx)
forall {m :: * -> *} {tx}.
(MonadSTM m, IsChainState tx) =>
TVar m (ChainStateHistory tx)
-> ChainSlot -> STM m (ChainStateType tx)
rollback TVar m (ChainStateHistory tx)
tv
, $sel:history:LocalChainState :: STM m (ChainStateHistory tx)
history = TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv
}
where
getLatest :: TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
getLatest TVar m (ChainStateHistory tx)
tv = ChainStateHistory tx -> ChainStateType tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState (ChainStateHistory tx -> ChainStateType tx)
-> STM m (ChainStateHistory tx) -> STM m (ChainStateType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv
pushNew :: TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
pushNew TVar m (ChainStateHistory tx)
tv ChainStateType tx
cs =
TVar m (ChainStateHistory tx)
-> (ChainStateHistory tx -> ChainStateHistory tx) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m (ChainStateHistory tx)
tv (ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
cs)
rollback :: TVar m (ChainStateHistory tx)
-> ChainSlot -> STM m (ChainStateType tx)
rollback TVar m (ChainStateHistory tx)
tv ChainSlot
chainSlot = do
ChainStateHistory tx
rolledBack <-
TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv
STM m (ChainStateHistory tx)
-> (ChainStateHistory tx -> ChainStateHistory tx)
-> STM m (ChainStateHistory tx)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory ChainSlot
chainSlot
TVar m (ChainStateHistory tx) -> ChainStateHistory tx -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainStateHistory tx)
tv ChainStateHistory tx
rolledBack
ChainStateType tx -> STM m (ChainStateType tx)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainStateHistory tx -> ChainStateType tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState ChainStateHistory tx
rolledBack)
type SubmitTx m = Tx -> m ()
type GetTimeHandle m = m TimeHandle
mkChain ::
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m DirectChainLog ->
GetTimeHandle m ->
TinyWallet m ->
ChainContext ->
LocalChainState m Tx ->
SubmitTx m ->
Chain Tx m
mkChain :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain Tracer m DirectChainLog
tracer GetTimeHandle m
queryTimeHandle wallet :: TinyWallet m
wallet@TinyWallet{STM m (Map TxIn TxOut)
getUTxO :: STM m (Map TxIn TxOut)
$sel:getUTxO:TinyWallet :: forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO} ChainContext
ctx LocalChainState{STM m (ChainStateType Tx)
$sel:getLatest:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType Tx)
getLatest} SubmitTx m
submitTx =
Chain
{ $sel:postTx:Chain :: MonadThrow m => PostChainTx Tx -> m ()
postTx = \PostChainTx Tx
tx -> do
ChainStateAt{UTxO
spendableUTxO :: UTxO
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
spendableUTxO} <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ ToPost{$sel:toPost:ToPost :: PostChainTx Tx
toPost = PostChainTx Tx
tx}
TimeHandle
timeHandle <- GetTimeHandle m
queryTimeHandle
Tx
vtx <-
STM m Tx -> m Tx
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TimeHandle
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
prepareTxToPost TimeHandle
timeHandle TinyWallet m
wallet ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO PostChainTx Tx
tx)
m Tx -> (Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO
spendableUTxO UTxO
forall a. Monoid a => a
mempty
SubmitTx m
submitTx Tx
vtx
,
$sel:draftCommitTx:Chain :: MonadThrow m =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> m (Either (PostTxError Tx) Tx)
draftCommitTx = \HeadId
headId UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit -> do
ChainStateAt{UTxO
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
spendableUTxO :: UTxO
spendableUTxO} <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
walletUtxos <- STM m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Map TxIn TxOut)
STM m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
getUTxO
let walletTxIns :: [TxIn]
walletTxIns = TxIn -> TxIn
fromLedgerTxIn (TxIn -> TxIn) -> [TxIn] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
walletUtxos
let userTxIns :: [TxIn]
userTxIns = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit
let matchedWalletUtxo :: [TxIn]
matchedWalletUtxo = (TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TxIn]
walletTxIns) [TxIn]
userTxIns
if [TxIn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxIn]
matchedWalletUtxo
then
(Tx -> m Tx)
-> Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either (PostTxError Tx) a -> f (Either (PostTxError Tx) b)
traverse (TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO
spendableUTxO ((TxOut CtxUTxO, Witness WitCtxTxIn) -> TxOut CtxUTxO
forall a b. (a, b) -> a
fst ((TxOut CtxUTxO, Witness WitCtxTxIn) -> TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit)) (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
$
ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit
else 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
SpendingNodeUtxoForbidden
,
MonadThrow m => SubmitTx m
SubmitTx m
submitTx :: SubmitTx m
$sel:submitTx:Chain :: MonadThrow m => SubmitTx m
submitTx
}
finalizeTx ::
MonadThrow m =>
TinyWallet m ->
ChainContext ->
UTxO.UTxO ->
UTxO.UTxO ->
Tx ->
m Tx
finalizeTx :: forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet{Tx -> Tx
sign :: Tx -> Tx
$sel:sign:TinyWallet :: forall (m :: * -> *). TinyWallet m -> Tx -> Tx
sign, UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee :: UTxO -> Tx -> m (Either ErrCoverFee Tx)
$sel:coverFee:TinyWallet :: forall (m :: * -> *).
TinyWallet m -> UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee} ChainContext
ctx UTxO
utxo UTxO
userUTxO Tx
partialTx = do
let headUTxO :: UTxO
headUTxO = ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
userUTxO
UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee UTxO
headUTxO Tx
partialTx m (Either ErrCoverFee Tx)
-> (Either ErrCoverFee Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ErrCoverFee
ErrNoFuelUTxOFound ->
PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PostTxError Tx
forall tx. PostTxError tx
NoFuelUTXOFound :: PostTxError Tx)
Left ErrNotEnoughFunds{} ->
PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PostTxError Tx
forall tx. PostTxError tx
NotEnoughFuel :: PostTxError Tx)
Left ErrScriptExecutionFailed{$sel:scriptFailure:ErrNotEnoughFunds :: ErrCoverFee
-> (PlutusPurpose AsIndex LedgerEra,
TransactionScriptFailure LedgerEra)
scriptFailure = (PlutusPurpose AsIndex LedgerEra
redeemerPtr, TransactionScriptFailure LedgerEra
scriptFailure)} ->
PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
( ScriptFailedInWallet
{ $sel:redeemerPtr:NoSeedInput :: Text
redeemerPtr = AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show PlutusPurpose AsIndex LedgerEra
AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto)
redeemerPtr
, $sel:failureReason:NoSeedInput :: Text
failureReason = TransactionScriptFailure (BabbageEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show TransactionScriptFailure LedgerEra
TransactionScriptFailure (BabbageEra StandardCrypto)
scriptFailure
} ::
PostTxError Tx
)
Left ErrCoverFee
e -> do
PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
( InternalWalletError
{ UTxO
UTxOType Tx
headUTxO :: UTxO
$sel:headUTxO:NoSeedInput :: UTxOType Tx
headUTxO
, $sel:reason:NoSeedInput :: Text
reason = ErrCoverFee -> Text
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
e
, $sel:tx:NoSeedInput :: Tx
tx = Tx
partialTx
} ::
PostTxError Tx
)
Right Tx
balancedTx -> do
Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> m Tx) -> Tx -> m Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Tx
sign Tx
balancedTx
data ChainSyncHandler m = ChainSyncHandler
{ forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward :: BlockHeader -> [Tx] -> m ()
, forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
onRollBackward :: ChainPoint -> m ()
}
data TimeConversionException = TimeConversionException
{ TimeConversionException -> SlotNo
slotNo :: SlotNo
, TimeConversionException -> Text
reason :: Text
}
deriving stock (TimeConversionException -> TimeConversionException -> Bool
(TimeConversionException -> TimeConversionException -> Bool)
-> (TimeConversionException -> TimeConversionException -> Bool)
-> Eq TimeConversionException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeConversionException -> TimeConversionException -> Bool
== :: TimeConversionException -> TimeConversionException -> Bool
$c/= :: TimeConversionException -> TimeConversionException -> Bool
/= :: TimeConversionException -> TimeConversionException -> Bool
Eq, Int -> TimeConversionException -> ShowS
[TimeConversionException] -> ShowS
TimeConversionException -> String
(Int -> TimeConversionException -> ShowS)
-> (TimeConversionException -> String)
-> ([TimeConversionException] -> ShowS)
-> Show TimeConversionException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeConversionException -> ShowS
showsPrec :: Int -> TimeConversionException -> ShowS
$cshow :: TimeConversionException -> String
show :: TimeConversionException -> String
$cshowList :: [TimeConversionException] -> ShowS
showList :: [TimeConversionException] -> ShowS
Show)
deriving anyclass (Show TimeConversionException
Typeable TimeConversionException
(Typeable TimeConversionException, Show TimeConversionException) =>
(TimeConversionException -> SomeException)
-> (SomeException -> Maybe TimeConversionException)
-> (TimeConversionException -> String)
-> Exception TimeConversionException
SomeException -> Maybe TimeConversionException
TimeConversionException -> String
TimeConversionException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: TimeConversionException -> SomeException
toException :: TimeConversionException -> SomeException
$cfromException :: SomeException -> Maybe TimeConversionException
fromException :: SomeException -> Maybe TimeConversionException
$cdisplayException :: TimeConversionException -> String
displayException :: TimeConversionException -> String
Exception)
chainSyncHandler ::
forall m.
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog ->
ChainCallback Tx m ->
GetTimeHandle m ->
ChainContext ->
LocalChainState m Tx ->
ChainSyncHandler m
chainSyncHandler :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer m DirectChainLog
tracer ChainCallback Tx m
callback GetTimeHandle m
getTimeHandle ChainContext
ctx LocalChainState m Tx
localChainState =
ChainSyncHandler
{ ChainPoint -> m ()
$sel:onRollBackward:ChainSyncHandler :: ChainPoint -> m ()
onRollBackward :: ChainPoint -> m ()
onRollBackward
, BlockHeader -> [Tx] -> m ()
$sel:onRollForward:ChainSyncHandler :: BlockHeader -> [Tx] -> m ()
onRollForward :: BlockHeader -> [Tx] -> m ()
onRollForward
}
where
ChainContext{NetworkId
networkId :: NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId} = ChainContext
ctx
LocalChainState{ChainSlot -> STM m (ChainStateType Tx)
$sel:rollback:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> ChainSlot -> STM m (ChainStateType tx)
rollback :: ChainSlot -> STM m (ChainStateType Tx)
rollback, STM m (ChainStateType Tx)
$sel:getLatest:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType Tx)
getLatest, ChainStateType Tx -> STM m ()
$sel:pushNew:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> ChainStateType tx -> STM m ()
pushNew :: ChainStateType Tx -> STM m ()
pushNew} = LocalChainState m Tx
localChainState
onRollBackward :: ChainPoint -> m ()
onRollBackward :: ChainPoint -> m ()
onRollBackward ChainPoint
point = do
Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ RolledBackward{ChainPoint
point :: ChainPoint
$sel:point:ToPost :: ChainPoint
point}
ChainStateAt
rolledBackChainState <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ChainStateAt -> m ChainStateAt)
-> STM m ChainStateAt -> m ChainStateAt
forall a b. (a -> b) -> a -> b
$ ChainSlot -> STM m (ChainStateType Tx)
rollback (ChainPoint -> ChainSlot
chainSlotFromPoint ChainPoint
point)
ChainCallback Tx m
callback Rollback{ChainStateType Tx
ChainStateAt
rolledBackChainState :: ChainStateAt
$sel:rolledBackChainState:Observation :: ChainStateType Tx
rolledBackChainState}
onRollForward :: BlockHeader -> [Tx] -> m ()
onRollForward :: BlockHeader -> [Tx] -> m ()
onRollForward BlockHeader
header [Tx]
receivedTxs = do
let point :: ChainPoint
point = BlockHeader -> ChainPoint
getChainPoint BlockHeader
header
Tracer m DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> m ()
forall a b. (a -> b) -> a -> b
$
RolledForward
{ ChainPoint
$sel:point:ToPost :: ChainPoint
point :: ChainPoint
point
, $sel:receivedTxIds:ToPost :: [TxId]
receivedTxIds = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> (Tx -> TxBody Era) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody (Tx -> TxId) -> [Tx] -> [TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx]
receivedTxs
}
case ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
point of
Maybe SlotNo
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SlotNo
slotNo -> do
TimeHandle
timeHandle <- GetTimeHandle m
getTimeHandle
case TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
slotNo of
Left Text
reason ->
TimeConversionException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TimeConversionException{SlotNo
$sel:slotNo:TimeConversionException :: SlotNo
slotNo :: SlotNo
slotNo, Text
$sel:reason:TimeConversionException :: Text
reason :: Text
reason}
Right UTCTime
utcTime -> do
let chainSlot :: 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
slotNo
ChainCallback Tx m
callback (Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
utcTime, ChainSlot
chainSlot :: ChainSlot
$sel:chainSlot:Observation :: ChainSlot
chainSlot})
[Tx] -> (Tx -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tx]
receivedTxs ((Tx -> m ()) -> m ()) -> (Tx -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx ChainPoint
point (Tx -> m (Maybe (ChainEvent Tx)))
-> (Maybe (ChainEvent Tx) -> m ()) -> Tx -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
Maybe (ChainEvent Tx)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just ChainEvent Tx
event -> ChainCallback Tx m
callback ChainEvent Tx
event
maybeObserveSomeTx :: ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx ChainPoint
point Tx
tx = STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx)))
-> STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx))
forall a b. (a -> b) -> a -> b
$ do
ChainStateAt{UTxO
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
spendableUTxO :: UTxO
spendableUTxO} <- STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
let observation :: HeadObservation
observation = NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO
spendableUTxO Tx
tx
case HeadObservation -> Maybe (OnChainTx Tx)
convertObservation HeadObservation
observation of
Maybe (OnChainTx Tx)
Nothing -> Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChainEvent Tx)
forall a. Maybe a
Nothing
Just OnChainTx Tx
observedTx -> do
let newChainState :: ChainStateAt
newChainState =
ChainStateAt
{ $sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = Tx -> UTxO -> UTxO
adjustUTxO Tx
tx UTxO
spendableUTxO
, $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just ChainPoint
point
}
ChainStateType Tx -> STM m ()
pushNew ChainStateType Tx
ChainStateAt
newChainState
Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx)))
-> Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a b. (a -> b) -> a -> b
$ ChainEvent Tx -> Maybe (ChainEvent Tx)
forall a. a -> Maybe a
Just Observation{OnChainTx Tx
observedTx :: OnChainTx Tx
$sel:observedTx:Observation :: OnChainTx Tx
observedTx, ChainStateType Tx
ChainStateAt
newChainState :: ChainStateAt
$sel:newChainState:Observation :: ChainStateType Tx
newChainState}
convertObservation :: HeadObservation -> Maybe (OnChainTx Tx)
convertObservation :: HeadObservation -> Maybe (OnChainTx Tx)
convertObservation = \case
HeadObservation
NoHeadTx -> Maybe (OnChainTx Tx)
forall a. Maybe a
Nothing
Init InitObservation{HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties, TxIn
seedTxIn :: TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn, [OnChainId]
participants :: [OnChainId]
$sel:participants:InitObservation :: InitObservation -> [OnChainId]
participants} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
OnInitTx
{ HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
, $sel:headSeed:OnInitTx :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn
, $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:HeadParameters :: [Party]
parties}
, [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
}
Abort AbortObservation{HeadId
headId :: HeadId
$sel:headId:AbortObservation :: AbortObservation -> HeadId
headId} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnAbortTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
Commit CommitObservation{HeadId
headId :: HeadId
$sel:headId:CommitObservation :: CommitObservation -> HeadId
headId, Party
party :: Party
$sel:party:CommitObservation :: CommitObservation -> Party
party, UTxO
committed :: UTxO
$sel:committed:CommitObservation :: CommitObservation -> UTxO
committed} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnCommitTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, Party
party :: Party
$sel:party:OnInitTx :: Party
party, UTxO
UTxOType Tx
committed :: UTxO
$sel:committed:OnInitTx :: UTxOType Tx
committed}
CollectCom CollectComObservation{HeadId
headId :: HeadId
$sel:headId:CollectComObservation :: CollectComObservation -> HeadId
headId} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnCollectComTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
Close CloseObservation{HeadId
headId :: HeadId
$sel:headId:CloseObservation :: CloseObservation -> HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:CloseObservation :: CloseObservation -> SnapshotNumber
snapshotNumber, $sel:threadOutput:CloseObservation :: CloseObservation -> ClosedThreadOutput
threadOutput = ClosedThreadOutput{POSIXTime
closedContestationDeadline :: POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline}} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
OnCloseTx
{ HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId
, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber
, $sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closedContestationDeadline
}
Contest ContestObservation{UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ContestObservation :: ContestObservation -> UTCTime
contestationDeadline, HeadId
headId :: HeadId
$sel:headId:ContestObservation :: ContestObservation -> HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:ContestObservation :: ContestObservation -> SnapshotNumber
snapshotNumber} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnContestTx{UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline, HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
Fanout FanoutObservation{HeadId
headId :: HeadId
$sel:headId:FanoutObservation :: FanoutObservation -> HeadId
headId} ->
OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnFanoutTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
prepareTxToPost ::
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle ->
TinyWallet m ->
ChainContext ->
UTxOType Tx ->
PostChainTx Tx ->
STM m Tx
prepareTxToPost :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
prepareTxToPost TimeHandle
timeHandle TinyWallet m
wallet ChainContext
ctx UTxOType Tx
spendableUTxO PostChainTx Tx
tx =
case PostChainTx Tx
tx of
InitTx{[OnChainId]
participants :: [OnChainId]
$sel:participants:InitTx :: forall tx. PostChainTx tx -> [OnChainId]
participants, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters} ->
TinyWallet m -> STM m (Maybe TxIn)
forall (m :: * -> *). TinyWallet m -> STM m (Maybe TxIn)
getSeedInput TinyWallet m
wallet STM m (Maybe TxIn) -> (Maybe TxIn -> STM m Tx) -> STM m Tx
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just TxIn
seedInput ->
Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> STM m Tx) -> Tx -> STM m Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
ctx TxIn
seedInput [OnChainId]
participants HeadParameters
headParameters
Maybe TxIn
Nothing ->
PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
NoSeedInput @Tx)
AbortTx{UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed} ->
case HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed of
Maybe TxIn
Nothing ->
PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InvalidSeed{HeadSeed
headSeed :: HeadSeed
$sel:headSeed:NoSeedInput :: HeadSeed
headSeed} :: PostTxError Tx)
Just TxIn
seedTxIn ->
case ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
UTxOType Tx
spendableUTxO UTxO
UTxOType Tx
utxo of
Left AbortTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructAbortTx @Tx)
Right Tx
abortTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
abortTx
CollectComTx{UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType Tx
utxo, HeadId
headId :: HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} ->
case ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
UTxOType Tx
utxo UTxO
UTxOType Tx
spendableUTxO of
Left CollectTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructCollectTx @Tx)
Right Tx
collectTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
collectTx
CloseTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot Tx
confirmedSnapshot :: ConfirmedSnapshot Tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot} -> do
(SlotNo
currentSlot, UTCTime
currentTime) <- Either Text (SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall {b}. Either Text b -> STM m b
throwLeft Either Text (SlotNo, UTCTime)
currentPointInTime
let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
(SlotNo, UTCTime)
upperBound <- UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
case ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> (SlotNo, UTCTime)
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
currentSlot (SlotNo, UTCTime)
upperBound of
Left CloseTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructCloseTx @Tx)
Right Tx
closeTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
closeTx
ContestTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot Tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot Tx
confirmedSnapshot} -> do
(SlotNo
_, UTCTime
currentTime) <- Either Text (SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall {b}. Either Text b -> STM m b
throwLeft Either Text (SlotNo, UTCTime)
currentPointInTime
let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
(SlotNo, UTCTime)
upperBound <- UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
case ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> (SlotNo, UTCTime)
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot (SlotNo, UTCTime)
upperBound of
Left ContestTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructContestTx @Tx)
Right Tx
contestTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
contestTx
FanoutTx{UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType Tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline} -> do
SlotNo
deadlineSlot <- Either Text SlotNo -> STM m SlotNo
forall {b}. Either Text b -> STM m b
throwLeft (Either Text SlotNo -> STM m SlotNo)
-> Either Text SlotNo -> STM m SlotNo
forall a b. (a -> b) -> a -> b
$ UTCTime -> Either Text SlotNo
slotFromUTCTime UTCTime
contestationDeadline
case HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed of
Maybe TxIn
Nothing ->
PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InvalidSeed{HeadSeed
$sel:headSeed:NoSeedInput :: HeadSeed
headSeed :: HeadSeed
headSeed} :: PostTxError Tx)
Just TxIn
seedTxIn ->
case ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO TxIn
seedTxIn UTxO
UTxOType Tx
utxo SlotNo
deadlineSlot of
Left FanoutTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructFanoutTx @Tx)
Right Tx
fanoutTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
fanoutTx
where
throwLeft :: Either Text b -> STM m b
throwLeft = (Text -> STM m b) -> (b -> STM m b) -> Either Text b -> STM m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> STM m b
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m b) -> (Text -> IOError) -> Text -> STM m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IOError) -> (Text -> String) -> Text -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) b -> STM m b
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
TimeHandle{Either Text (SlotNo, UTCTime)
currentPointInTime :: Either Text (SlotNo, UTCTime)
$sel:currentPointInTime:TimeHandle :: TimeHandle -> Either Text (SlotNo, UTCTime)
currentPointInTime, UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: TimeHandle -> UTCTime -> Either Text SlotNo
slotFromUTCTime} = TimeHandle
timeHandle
calculateTxUpperBoundFromContestationPeriod :: UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod = do
let effectiveDelay :: NominalDiffTime
effectiveDelay = NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
min (ContestationPeriod -> NominalDiffTime
toNominalDiffTime ContestationPeriod
contestationPeriod) NominalDiffTime
maxGraceTime
let upperBoundTime :: UTCTime
upperBoundTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
effectiveDelay UTCTime
currentTime
SlotNo
upperBoundSlot <- Either Text SlotNo -> STM m SlotNo
forall {b}. Either Text b -> STM m b
throwLeft (Either Text SlotNo -> STM m SlotNo)
-> Either Text SlotNo -> STM m SlotNo
forall a b. (a -> b) -> a -> b
$ UTCTime -> Either Text SlotNo
slotFromUTCTime UTCTime
upperBoundTime
(SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
upperBoundSlot, UTCTime
upperBoundTime)
maxGraceTime :: NominalDiffTime
maxGraceTime :: NominalDiffTime
maxGraceTime = NominalDiffTime
200
data DirectChainLog
= ToPost {DirectChainLog -> PostChainTx Tx
toPost :: PostChainTx Tx}
| PostingTx {DirectChainLog -> TxId
txId :: TxId}
| PostedTx {txId :: TxId}
| PostingFailed {DirectChainLog -> Tx
tx :: Tx, DirectChainLog -> PostTxError Tx
postTxError :: PostTxError Tx}
| RolledForward {DirectChainLog -> ChainPoint
point :: ChainPoint, DirectChainLog -> [TxId]
receivedTxIds :: [TxId]}
| RolledBackward {point :: ChainPoint}
| Wallet TinyWalletLog
deriving stock (DirectChainLog -> DirectChainLog -> Bool
(DirectChainLog -> DirectChainLog -> Bool)
-> (DirectChainLog -> DirectChainLog -> Bool) -> Eq DirectChainLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DirectChainLog -> DirectChainLog -> Bool
== :: DirectChainLog -> DirectChainLog -> Bool
$c/= :: DirectChainLog -> DirectChainLog -> Bool
/= :: DirectChainLog -> DirectChainLog -> Bool
Eq, Int -> DirectChainLog -> ShowS
[DirectChainLog] -> ShowS
DirectChainLog -> String
(Int -> DirectChainLog -> ShowS)
-> (DirectChainLog -> String)
-> ([DirectChainLog] -> ShowS)
-> Show DirectChainLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DirectChainLog -> ShowS
showsPrec :: Int -> DirectChainLog -> ShowS
$cshow :: DirectChainLog -> String
show :: DirectChainLog -> String
$cshowList :: [DirectChainLog] -> ShowS
showList :: [DirectChainLog] -> ShowS
Show, (forall x. DirectChainLog -> Rep DirectChainLog x)
-> (forall x. Rep DirectChainLog x -> DirectChainLog)
-> Generic DirectChainLog
forall x. Rep DirectChainLog x -> DirectChainLog
forall x. DirectChainLog -> Rep DirectChainLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DirectChainLog -> Rep DirectChainLog x
from :: forall x. DirectChainLog -> Rep DirectChainLog x
$cto :: forall x. Rep DirectChainLog x -> DirectChainLog
to :: forall x. Rep DirectChainLog x -> DirectChainLog
Generic)
deriving anyclass ([DirectChainLog] -> Value
[DirectChainLog] -> Encoding
DirectChainLog -> Bool
DirectChainLog -> Value
DirectChainLog -> Encoding
(DirectChainLog -> Value)
-> (DirectChainLog -> Encoding)
-> ([DirectChainLog] -> Value)
-> ([DirectChainLog] -> Encoding)
-> (DirectChainLog -> Bool)
-> ToJSON DirectChainLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DirectChainLog -> Value
toJSON :: DirectChainLog -> Value
$ctoEncoding :: DirectChainLog -> Encoding
toEncoding :: DirectChainLog -> Encoding
$ctoJSONList :: [DirectChainLog] -> Value
toJSONList :: [DirectChainLog] -> Value
$ctoEncodingList :: [DirectChainLog] -> Encoding
toEncodingList :: [DirectChainLog] -> Encoding
$comitField :: DirectChainLog -> Bool
omitField :: DirectChainLog -> Bool
ToJSON, Maybe DirectChainLog
Value -> Parser [DirectChainLog]
Value -> Parser DirectChainLog
(Value -> Parser DirectChainLog)
-> (Value -> Parser [DirectChainLog])
-> Maybe DirectChainLog
-> FromJSON DirectChainLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DirectChainLog
parseJSON :: Value -> Parser DirectChainLog
$cparseJSONList :: Value -> Parser [DirectChainLog]
parseJSONList :: Value -> Parser [DirectChainLog]
$comittedField :: Maybe DirectChainLog
omittedField :: Maybe DirectChainLog
FromJSON)
instance Arbitrary DirectChainLog where
arbitrary :: Gen DirectChainLog
arbitrary = Gen DirectChainLog
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
shrink :: DirectChainLog -> [DirectChainLog]
shrink = DirectChainLog -> [DirectChainLog]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink