{-# LANGUAGE AllowAmbiguousTypes #-}
module Hydra.Ledger where
import Hydra.Prelude
import Data.Aeson (FromJSONKey, ToJSONKey)
import Test.QuickCheck.Instances.Natural ()
import Test.QuickCheck.Instances.Text ()
class
( Eq tx
, Show tx
, Typeable tx
, Arbitrary tx
, FromCBOR tx
, ToCBOR tx
, FromJSON tx
, ToJSON tx
,
Eq (TxIdType tx)
, Ord (TxIdType tx)
, Show (TxIdType tx)
, Typeable (TxIdType tx)
, Arbitrary (TxIdType tx)
, FromJSON (TxIdType tx)
, ToJSON (TxIdType tx)
, FromCBOR (TxIdType tx)
, ToCBOR (TxIdType tx)
, FromJSONKey (TxIdType tx)
, ToJSONKey (TxIdType tx)
,
Eq (UTxOType tx)
, Show (UTxOType tx)
, Arbitrary (UTxOType tx)
, FromJSON (UTxOType tx)
, Monoid (UTxOType tx)
, ToJSON (UTxOType tx)
, FromCBOR (UTxOType tx)
, ToCBOR (UTxOType tx)
) =>
IsTx tx
where
type UTxOType tx
type TxIdType tx
type ValueType tx
txId :: tx -> TxIdType tx
balance :: UTxOType tx -> ValueType tx
hashUTxO :: UTxOType tx -> ByteString
newtype ChainSlot = ChainSlot Natural
deriving stock (Eq ChainSlot
Eq ChainSlot =>
(ChainSlot -> ChainSlot -> Ordering)
-> (ChainSlot -> ChainSlot -> Bool)
-> (ChainSlot -> ChainSlot -> Bool)
-> (ChainSlot -> ChainSlot -> Bool)
-> (ChainSlot -> ChainSlot -> Bool)
-> (ChainSlot -> ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot -> ChainSlot)
-> Ord ChainSlot
ChainSlot -> ChainSlot -> Bool
ChainSlot -> ChainSlot -> Ordering
ChainSlot -> ChainSlot -> ChainSlot
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ChainSlot -> ChainSlot -> Ordering
compare :: ChainSlot -> ChainSlot -> Ordering
$c< :: ChainSlot -> ChainSlot -> Bool
< :: ChainSlot -> ChainSlot -> Bool
$c<= :: ChainSlot -> ChainSlot -> Bool
<= :: ChainSlot -> ChainSlot -> Bool
$c> :: ChainSlot -> ChainSlot -> Bool
> :: ChainSlot -> ChainSlot -> Bool
$c>= :: ChainSlot -> ChainSlot -> Bool
>= :: ChainSlot -> ChainSlot -> Bool
$cmax :: ChainSlot -> ChainSlot -> ChainSlot
max :: ChainSlot -> ChainSlot -> ChainSlot
$cmin :: ChainSlot -> ChainSlot -> ChainSlot
min :: ChainSlot -> ChainSlot -> ChainSlot
Ord, ChainSlot -> ChainSlot -> Bool
(ChainSlot -> ChainSlot -> Bool)
-> (ChainSlot -> ChainSlot -> Bool) -> Eq ChainSlot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainSlot -> ChainSlot -> Bool
== :: ChainSlot -> ChainSlot -> Bool
$c/= :: ChainSlot -> ChainSlot -> Bool
/= :: ChainSlot -> ChainSlot -> Bool
Eq, Int -> ChainSlot -> ShowS
[ChainSlot] -> ShowS
ChainSlot -> String
(Int -> ChainSlot -> ShowS)
-> (ChainSlot -> String)
-> ([ChainSlot] -> ShowS)
-> Show ChainSlot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSlot -> ShowS
showsPrec :: Int -> ChainSlot -> ShowS
$cshow :: ChainSlot -> String
show :: ChainSlot -> String
$cshowList :: [ChainSlot] -> ShowS
showList :: [ChainSlot] -> ShowS
Show, (forall x. ChainSlot -> Rep ChainSlot x)
-> (forall x. Rep ChainSlot x -> ChainSlot) -> Generic ChainSlot
forall x. Rep ChainSlot x -> ChainSlot
forall x. ChainSlot -> Rep ChainSlot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainSlot -> Rep ChainSlot x
from :: forall x. ChainSlot -> Rep ChainSlot x
$cto :: forall x. Rep ChainSlot x -> ChainSlot
to :: forall x. Rep ChainSlot x -> ChainSlot
Generic)
deriving newtype (Integer -> ChainSlot
ChainSlot -> ChainSlot
ChainSlot -> ChainSlot -> ChainSlot
(ChainSlot -> ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot)
-> (ChainSlot -> ChainSlot)
-> (Integer -> ChainSlot)
-> Num ChainSlot
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: ChainSlot -> ChainSlot -> ChainSlot
+ :: ChainSlot -> ChainSlot -> ChainSlot
$c- :: ChainSlot -> ChainSlot -> ChainSlot
- :: ChainSlot -> ChainSlot -> ChainSlot
$c* :: ChainSlot -> ChainSlot -> ChainSlot
* :: ChainSlot -> ChainSlot -> ChainSlot
$cnegate :: ChainSlot -> ChainSlot
negate :: ChainSlot -> ChainSlot
$cabs :: ChainSlot -> ChainSlot
abs :: ChainSlot -> ChainSlot
$csignum :: ChainSlot -> ChainSlot
signum :: ChainSlot -> ChainSlot
$cfromInteger :: Integer -> ChainSlot
fromInteger :: Integer -> ChainSlot
Num, [ChainSlot] -> Value
[ChainSlot] -> Encoding
ChainSlot -> Bool
ChainSlot -> Value
ChainSlot -> Encoding
(ChainSlot -> Value)
-> (ChainSlot -> Encoding)
-> ([ChainSlot] -> Value)
-> ([ChainSlot] -> Encoding)
-> (ChainSlot -> Bool)
-> ToJSON ChainSlot
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainSlot -> Value
toJSON :: ChainSlot -> Value
$ctoEncoding :: ChainSlot -> Encoding
toEncoding :: ChainSlot -> Encoding
$ctoJSONList :: [ChainSlot] -> Value
toJSONList :: [ChainSlot] -> Value
$ctoEncodingList :: [ChainSlot] -> Encoding
toEncodingList :: [ChainSlot] -> Encoding
$comitField :: ChainSlot -> Bool
omitField :: ChainSlot -> Bool
ToJSON, Maybe ChainSlot
Value -> Parser [ChainSlot]
Value -> Parser ChainSlot
(Value -> Parser ChainSlot)
-> (Value -> Parser [ChainSlot])
-> Maybe ChainSlot
-> FromJSON ChainSlot
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainSlot
parseJSON :: Value -> Parser ChainSlot
$cparseJSONList :: Value -> Parser [ChainSlot]
parseJSONList :: Value -> Parser [ChainSlot]
$comittedField :: Maybe ChainSlot
omittedField :: Maybe ChainSlot
FromJSON)
instance Arbitrary ChainSlot where
arbitrary :: Gen ChainSlot
arbitrary = Gen ChainSlot
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
nextChainSlot :: ChainSlot -> ChainSlot
nextChainSlot :: ChainSlot -> ChainSlot
nextChainSlot (ChainSlot Natural
n) = Natural -> ChainSlot
ChainSlot (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
newtype Ledger tx = Ledger
{ forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ::
ChainSlot ->
UTxOType tx ->
[tx] ->
Either (tx, ValidationError) (UTxOType tx)
}
canApply :: Ledger tx -> ChainSlot -> UTxOType tx -> tx -> ValidationResult
canApply :: forall tx.
Ledger tx -> ChainSlot -> UTxOType tx -> tx -> ValidationResult
canApply Ledger tx
ledger ChainSlot
slot UTxOType tx
utxo tx
tx =
((tx, ValidationError) -> ValidationResult)
-> (UTxOType tx -> ValidationResult)
-> Either (tx, ValidationError) (UTxOType tx)
-> ValidationResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ValidationError -> ValidationResult
Invalid (ValidationError -> ValidationResult)
-> ((tx, ValidationError) -> ValidationError)
-> (tx, ValidationError)
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tx, ValidationError) -> ValidationError
forall a b. (a, b) -> b
snd) (ValidationResult -> UTxOType tx -> ValidationResult
forall a b. a -> b -> a
const ValidationResult
Valid) (Either (tx, ValidationError) (UTxOType tx) -> ValidationResult)
-> Either (tx, ValidationError) (UTxOType tx) -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger tx
ledger ChainSlot
slot UTxOType tx
utxo (tx -> [tx]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure tx
tx)
collectTransactions :: Ledger tx -> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
collectTransactions :: forall tx.
Ledger tx
-> ChainSlot -> UTxOType tx -> [tx] -> ([tx], UTxOType tx)
collectTransactions Ledger{ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
$sel:applyTransactions:Ledger :: forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions :: ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions} ChainSlot
slot UTxOType tx
utxo =
(tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx))
-> ([tx], UTxOType tx) -> [tx] -> ([tx], UTxOType tx)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx)
go ([], UTxOType tx
utxo)
where
go :: tx -> ([tx], UTxOType tx) -> ([tx], UTxOType tx)
go tx
tx ([tx]
applicableTxs, UTxOType tx
u) =
case ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions ChainSlot
slot UTxOType tx
u [tx
tx] of
Left (tx, ValidationError)
_ -> ([tx]
applicableTxs, UTxOType tx
u)
Right UTxOType tx
u' -> ([tx]
applicableTxs [tx] -> [tx] -> [tx]
forall a. Semigroup a => a -> a -> a
<> [tx
tx], UTxOType tx
u')
data ValidationResult
= Valid
| Invalid ValidationError
deriving stock (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
/= :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationResult -> ShowS
showsPrec :: Int -> ValidationResult -> ShowS
$cshow :: ValidationResult -> String
show :: ValidationResult -> String
$cshowList :: [ValidationResult] -> ShowS
showList :: [ValidationResult] -> ShowS
Show, (forall x. ValidationResult -> Rep ValidationResult x)
-> (forall x. Rep ValidationResult x -> ValidationResult)
-> Generic ValidationResult
forall x. Rep ValidationResult x -> ValidationResult
forall x. ValidationResult -> Rep ValidationResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationResult -> Rep ValidationResult x
from :: forall x. ValidationResult -> Rep ValidationResult x
$cto :: forall x. Rep ValidationResult x -> ValidationResult
to :: forall x. Rep ValidationResult x -> ValidationResult
Generic)
deriving anyclass ([ValidationResult] -> Value
[ValidationResult] -> Encoding
ValidationResult -> Bool
ValidationResult -> Value
ValidationResult -> Encoding
(ValidationResult -> Value)
-> (ValidationResult -> Encoding)
-> ([ValidationResult] -> Value)
-> ([ValidationResult] -> Encoding)
-> (ValidationResult -> Bool)
-> ToJSON ValidationResult
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ValidationResult -> Value
toJSON :: ValidationResult -> Value
$ctoEncoding :: ValidationResult -> Encoding
toEncoding :: ValidationResult -> Encoding
$ctoJSONList :: [ValidationResult] -> Value
toJSONList :: [ValidationResult] -> Value
$ctoEncodingList :: [ValidationResult] -> Encoding
toEncodingList :: [ValidationResult] -> Encoding
$comitField :: ValidationResult -> Bool
omitField :: ValidationResult -> Bool
ToJSON, Maybe ValidationResult
Value -> Parser [ValidationResult]
Value -> Parser ValidationResult
(Value -> Parser ValidationResult)
-> (Value -> Parser [ValidationResult])
-> Maybe ValidationResult
-> FromJSON ValidationResult
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ValidationResult
parseJSON :: Value -> Parser ValidationResult
$cparseJSONList :: Value -> Parser [ValidationResult]
parseJSONList :: Value -> Parser [ValidationResult]
$comittedField :: Maybe ValidationResult
omittedField :: Maybe ValidationResult
FromJSON)
newtype ValidationError = ValidationError {ValidationError -> Text
reason :: Text}
deriving stock (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationError -> ShowS
showsPrec :: Int -> ValidationError -> ShowS
$cshow :: ValidationError -> String
show :: ValidationError -> String
$cshowList :: [ValidationError] -> ShowS
showList :: [ValidationError] -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationError -> Rep ValidationError x
from :: forall x. ValidationError -> Rep ValidationError x
$cto :: forall x. Rep ValidationError x -> ValidationError
to :: forall x. Rep ValidationError x -> ValidationError
Generic)
deriving anyclass ([ValidationError] -> Value
[ValidationError] -> Encoding
ValidationError -> Bool
ValidationError -> Value
ValidationError -> Encoding
(ValidationError -> Value)
-> (ValidationError -> Encoding)
-> ([ValidationError] -> Value)
-> ([ValidationError] -> Encoding)
-> (ValidationError -> Bool)
-> ToJSON ValidationError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ValidationError -> Value
toJSON :: ValidationError -> Value
$ctoEncoding :: ValidationError -> Encoding
toEncoding :: ValidationError -> Encoding
$ctoJSONList :: [ValidationError] -> Value
toJSONList :: [ValidationError] -> Value
$ctoEncodingList :: [ValidationError] -> Encoding
toEncodingList :: [ValidationError] -> Encoding
$comitField :: ValidationError -> Bool
omitField :: ValidationError -> Bool
ToJSON, Maybe ValidationError
Value -> Parser [ValidationError]
Value -> Parser ValidationError
(Value -> Parser ValidationError)
-> (Value -> Parser [ValidationError])
-> Maybe ValidationError
-> FromJSON ValidationError
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ValidationError
parseJSON :: Value -> Parser ValidationError
$cparseJSONList :: Value -> Parser [ValidationError]
parseJSONList :: Value -> Parser [ValidationError]
$comittedField :: Maybe ValidationError
omittedField :: Maybe ValidationError
FromJSON)
instance Arbitrary ValidationError where
arbitrary :: Gen ValidationError
arbitrary = Gen ValidationError
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary