{-# 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

  -- XXX(SN): this name easily conflicts
  txId :: tx -> TxIdType tx
  balance :: UTxOType tx -> ValueType tx

  -- | Hash a utxo set to be able to sign (off-chain) and verify it (on-chain).
  hashUTxO :: UTxOType tx -> ByteString

-- | A generic description for a chain slot all implementions need to use.
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

-- | Get the next chain slot. Use this instead of giving 'Enum' or 'Num'
-- instances to 'ChainSlot'.
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)

-- | An abstract interface for a 'Ledger'. Allows to define mock / simpler
-- implementation for testing as well as limiting feature-envy from the business
-- logic by forcing a closed interface.
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)
  -- ^ Apply a set of transaction to a given UTxO set. Returns the new UTxO or
  -- validation failures returned from the ledger.
  -- TODO: 'ValidationError' should also include the UTxO, which is not
  -- necessarily the same as the given UTxO after some transactions
  }

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)

-- | Collect applicable transactions and resulting UTxO. In contrast to
-- 'applyTransactions', this functions continues on validation errors.
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')

-- | Either valid or an error which we get from the ledger-specs tx validation.
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