{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Hydra.Ledger where

import Hydra.Prelude

import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Tx.IsTx (IsTx (..))
import Test.QuickCheck.Instances.Natural ()
import Test.QuickCheck.Instances.Text ()

-- | Get outputs of a transaction.
outputsOfTx :: IsTx tx => tx -> [TxOutType tx]
outputsOfTx :: forall tx. IsTx tx => tx -> [TxOutType tx]
outputsOfTx = UTxOType tx -> [TxOutType tx]
forall tx. IsTx tx => UTxOType tx -> [TxOutType tx]
outputsOfUTxO (UTxOType tx -> [TxOutType tx])
-> (tx -> UTxOType tx) -> tx -> [TxOutType tx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx

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