{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Test.Cardano.Chain.Elaboration.UTxO (
  elaborateUTxOEnv,
  elaborateUTxO,
  elaborateTxBody,
  elaborateTxBS,
  elaborateTxOut,
) where

import qualified Byron.Spec.Ledger.Core as Abstract
import qualified Byron.Spec.Ledger.STS.UTXO as Abstract
import qualified Byron.Spec.Ledger.UTxO as Abstract
import qualified Cardano.Chain.Common as Concrete
import qualified Cardano.Chain.UTxO as Concrete
import qualified Cardano.Chain.UTxO.UTxO as Concrete.UTxO
import qualified Cardano.Chain.UTxO.Validation as Concrete.UTxO
import qualified Cardano.Chain.Update as Concrete
import Cardano.Crypto
import qualified Cardano.Ledger.Binary as CBOR
import Cardano.Prelude
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Formatting hiding (bytes)
import Test.Cardano.Chain.Elaboration.Keys
import Test.Cardano.Chain.Genesis.Dummy
import qualified Test.Cardano.Crypto.Dummy as Dummy

elaborateUTxOEnv :: Abstract.UTxOEnv -> Concrete.UTxO.Environment
elaborateUTxOEnv :: UTxOEnv -> Environment
elaborateUTxOEnv UTxOEnv
_abstractEnv =
  Concrete.UTxO.Environment
    { protocolMagic :: AProtocolMagic ByteString
Concrete.UTxO.protocolMagic = AProtocolMagic ByteString
Dummy.aProtocolMagic
    , protocolParameters :: ProtocolParameters
Concrete.UTxO.protocolParameters =
        ProtocolParameters
dummyProtocolParameters
          { Concrete.ppTxFeePolicy =
              Concrete.TxFeePolicyTxSizeLinear
                $ Concrete.TxSizeLinear
                  (Concrete.mkKnownLovelace @0)
                  0
          }
    , utxoConfiguration :: UTxOConfiguration
Concrete.UTxO.utxoConfiguration = UTxOConfiguration
Concrete.defaultUTxOConfiguration
    }

elaborateUTxO ::
  (Abstract.TxId -> Concrete.TxId) ->
  Abstract.UTxO ->
  Concrete.UTxO
elaborateUTxO :: (TxId -> TxId) -> UTxO -> UTxO
elaborateUTxO TxId -> TxId
elaborateTxId =
  [(TxIn, TxOut)] -> UTxO
Concrete.UTxO.fromList
    ([(TxIn, TxOut)] -> UTxO)
-> (UTxO -> [(TxIn, TxOut)]) -> UTxO -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TxIn, TxOut) -> (TxIn, TxOut))
-> [(TxIn, TxOut)] -> [(TxIn, TxOut)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxId -> TxId) -> (TxIn, TxOut) -> (TxIn, TxOut)
elaborateUTxOEntry TxId -> TxId
elaborateTxId)
    ([(TxIn, TxOut)] -> [(TxIn, TxOut)])
-> (UTxO -> [(TxIn, TxOut)]) -> UTxO -> [(TxIn, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map TxIn TxOut -> [(TxIn, TxOut)]
forall k a. Map k a -> [(k, a)]
M.toList
    (Map TxIn TxOut -> [(TxIn, TxOut)])
-> (UTxO -> Map TxIn TxOut) -> UTxO -> [(TxIn, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTxO -> Map TxIn TxOut
Abstract.unUTxO

elaborateUTxOEntry ::
  (Abstract.TxId -> Concrete.TxId) ->
  (Abstract.TxIn, Abstract.TxOut) ->
  (Concrete.TxIn, Concrete.TxOut)
elaborateUTxOEntry :: (TxId -> TxId) -> (TxIn, TxOut) -> (TxIn, TxOut)
elaborateUTxOEntry TxId -> TxId
elaborateTxId (TxIn
abstractTxIn, TxOut
abstractTxOut) =
  (TxIn
concreteTxIn, TxOut
concreteTxOut)
  where
    concreteTxOut :: TxOut
concreteTxOut = TxOut -> TxOut
elaborateTxOut TxOut
abstractTxOut
    concreteTxIn :: TxIn
concreteTxIn = (TxId -> TxId) -> TxIn -> TxIn
elaborateTxIn TxId -> TxId
elaborateTxId TxIn
abstractTxIn

elaborateTxBS ::
  (Abstract.TxId -> Concrete.TxId) ->
  Abstract.Tx ->
  Concrete.ATxAux ByteString
elaborateTxBS :: (TxId -> TxId) -> Tx -> ATxAux ByteString
elaborateTxBS TxId -> TxId
elaborateTxId =
  TxAux -> ATxAux ByteString
annotateTxAux (TxAux -> ATxAux ByteString)
-> (Tx -> TxAux) -> Tx -> ATxAux ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (TxId -> TxId) -> Tx -> TxAux
elaborateTx TxId -> TxId
elaborateTxId
  where
    annotateTxAux :: Concrete.TxAux -> Concrete.ATxAux ByteString
    annotateTxAux :: TxAux -> ATxAux ByteString
annotateTxAux TxAux
txAux =
      (ByteSpan -> ByteString) -> ATxAux ByteSpan -> ATxAux ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
CBOR.slice ByteString
bytes)
        (ATxAux ByteSpan -> ATxAux ByteString)
-> (Either DecoderError (ATxAux ByteSpan) -> ATxAux ByteSpan)
-> Either DecoderError (ATxAux ByteSpan)
-> ATxAux ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ATxAux ByteSpan
-> Either DecoderError (ATxAux ByteSpan) -> ATxAux ByteSpan
forall b a. b -> Either a b -> b
fromRight (Text -> ATxAux ByteSpan
forall a. HasCallStack => Text -> a
panic Text
"elaborateTxBS: Error decoding TxAux")
        (Either DecoderError (ATxAux ByteSpan) -> ATxAux ByteString)
-> Either DecoderError (ATxAux ByteSpan) -> ATxAux ByteString
forall a b. (a -> b) -> a -> b
$ Version -> ByteString -> Either DecoderError (ATxAux ByteSpan)
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
CBOR.decodeFull Version
CBOR.byronProtVer ByteString
bytes
      where
        bytes :: ByteString
bytes = Version -> TxAux -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
CBOR.serialize Version
CBOR.byronProtVer TxAux
txAux

elaborateTx ::
  (Abstract.TxId -> Concrete.TxId) -> Abstract.Tx -> Concrete.TxAux
elaborateTx :: (TxId -> TxId) -> Tx -> TxAux
elaborateTx TxId -> TxId
elaborateTxId (Abstract.Tx TxBody
tx [Wit]
witnesses) =
  Tx -> TxWitness -> TxAux
Concrete.mkTxAux Tx
concreteTx (Tx -> [Wit] -> TxWitness
elaborateWitnesses Tx
concreteTx [Wit]
witnesses)
  where
    concreteTx :: Tx
concreteTx = (TxId -> TxId) -> TxBody -> Tx
elaborateTxBody TxId -> TxId
elaborateTxId TxBody
tx

elaborateTxBody :: (Abstract.TxId -> Concrete.TxId) -> Abstract.TxBody -> Concrete.Tx
elaborateTxBody :: (TxId -> TxId) -> TxBody -> Tx
elaborateTxBody TxId -> TxId
elaborateTxId (Abstract.TxBody [TxIn]
inputs [TxOut]
outputs) =
  Concrete.UnsafeTx
    { txInputs :: NonEmpty TxIn
Concrete.txInputs = (TxId -> TxId) -> [TxIn] -> NonEmpty TxIn
elaborateTxIns TxId -> TxId
elaborateTxId [TxIn]
inputs
    , txOutputs :: NonEmpty TxOut
Concrete.txOutputs = [TxOut] -> NonEmpty TxOut
elaborateTxOuts [TxOut]
outputs
    , txAttributes :: TxAttributes
Concrete.txAttributes = () -> TxAttributes
forall h. h -> Attributes h
Concrete.mkAttributes ()
    }

elaborateWitnesses :: Concrete.Tx -> [Abstract.Wit] -> Concrete.TxWitness
elaborateWitnesses :: Tx -> [Wit] -> TxWitness
elaborateWitnesses Tx
concreteTx = [TxInWitness] -> TxWitness
forall a. [a] -> Vector a
V.fromList ([TxInWitness] -> TxWitness)
-> ([Wit] -> [TxInWitness]) -> [Wit] -> TxWitness
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Wit -> TxInWitness) -> [Wit] -> [TxInWitness]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tx -> Wit -> TxInWitness
elaborateWitness Tx
concreteTx)

elaborateWitness :: Concrete.Tx -> Abstract.Wit -> Concrete.TxInWitness
elaborateWitness :: Tx -> Wit -> TxInWitness
elaborateWitness Tx
concreteTx (Abstract.Wit VKey
key Sig TxBody
_) =
  VerificationKey -> TxSig -> TxInWitness
Concrete.VKWitness
    VerificationKey
concreteVK
    TxSig
signature
  where
    (VerificationKey
concreteVK, SigningKey
concreteSK) = KeyPair -> (VerificationKey, SigningKey)
elaborateKeyPair (KeyPair -> (VerificationKey, SigningKey))
-> KeyPair -> (VerificationKey, SigningKey)
forall a b. (a -> b) -> a -> b
$ VKey -> KeyPair
vKeyPair VKey
key
    signature :: TxSig
signature = ProtocolMagicId -> SignTag -> SigningKey -> TxSigData -> TxSig
forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SigningKey -> a -> Signature a
sign ProtocolMagicId
Dummy.protocolMagicId SignTag
SignTx SigningKey
concreteSK TxSigData
sigData
    sigData :: TxSigData
sigData = TxId -> TxSigData
Concrete.TxSigData (TxId -> TxSigData) -> TxId -> TxSigData
forall a b. (a -> b) -> a -> b
$ Tx -> TxId
forall a. EncCBOR a => a -> Hash a
serializeCborHash Tx
concreteTx

elaborateTxIns ::
  (Abstract.TxId -> Concrete.TxId) ->
  [Abstract.TxIn] ->
  NonEmpty Concrete.TxIn
elaborateTxIns :: (TxId -> TxId) -> [TxIn] -> NonEmpty TxIn
elaborateTxIns TxId -> TxId
elaborateTxId =
  NonEmpty TxIn -> Maybe (NonEmpty TxIn) -> NonEmpty TxIn
forall a. a -> Maybe a -> a
fromMaybe (Text -> NonEmpty TxIn
forall a. HasCallStack => Text -> a
panic Text
"elaborateTxIns: Empty list of TxIns")
    (Maybe (NonEmpty TxIn) -> NonEmpty TxIn)
-> ([TxIn] -> Maybe (NonEmpty TxIn)) -> [TxIn] -> NonEmpty TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [TxIn] -> Maybe (NonEmpty TxIn)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    ([TxIn] -> Maybe (NonEmpty TxIn))
-> ([TxIn] -> [TxIn]) -> [TxIn] -> Maybe (NonEmpty TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (TxIn -> TxIn) -> [TxIn] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ((TxId -> TxId) -> TxIn -> TxIn
elaborateTxIn TxId -> TxId
elaborateTxId)

elaborateTxIn ::
  (Abstract.TxId -> Concrete.TxId) -> Abstract.TxIn -> Concrete.TxIn
elaborateTxIn :: (TxId -> TxId) -> TxIn -> TxIn
elaborateTxIn TxId -> TxId
elaborateTxId (Abstract.TxIn TxId
txId Natural
index) =
  TxId -> Word16 -> TxIn
Concrete.TxInUtxo (TxId -> TxId
elaborateTxId TxId
txId) (Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
index)

elaborateTxOuts :: [Abstract.TxOut] -> NonEmpty Concrete.TxOut
elaborateTxOuts :: [TxOut] -> NonEmpty TxOut
elaborateTxOuts =
  NonEmpty TxOut -> Maybe (NonEmpty TxOut) -> NonEmpty TxOut
forall a. a -> Maybe a -> a
fromMaybe
    ( Text -> NonEmpty TxOut
forall a. HasCallStack => Text -> a
panic
        Text
"elaborateTxOuts: Tried to elaborate an empty list of Abstract.TxOuts"
    )
    (Maybe (NonEmpty TxOut) -> NonEmpty TxOut)
-> ([TxOut] -> Maybe (NonEmpty TxOut)) -> [TxOut] -> NonEmpty TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [TxOut] -> Maybe (NonEmpty TxOut)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    ([TxOut] -> Maybe (NonEmpty TxOut))
-> ([TxOut] -> [TxOut]) -> [TxOut] -> Maybe (NonEmpty TxOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (TxOut -> TxOut) -> [TxOut] -> [TxOut]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut -> TxOut
elaborateTxOut

elaborateTxOut :: Abstract.TxOut -> Concrete.TxOut
elaborateTxOut :: TxOut -> TxOut
elaborateTxOut TxOut
abstractTxOut =
  Concrete.TxOut
    { txOutAddress :: Address
Concrete.txOutAddress =
        NetworkMagic -> VerificationKey -> Address
Concrete.makeVerKeyAddress
          (AProtocolMagic () -> NetworkMagic
forall a. AProtocolMagic a -> NetworkMagic
Concrete.makeNetworkMagic AProtocolMagic ()
Dummy.protocolMagic)
          (VKey -> VerificationKey
elaborateVKey VKey
abstractVK)
    , txOutValue :: Lovelace
Concrete.txOutValue = Lovelace
lovelaceValue
    }
  where
    Abstract.TxOut (Abstract.Addr VKey
abstractVK) (Abstract.Lovelace Integer
value) =
      TxOut
abstractTxOut

    lovelaceValue :: Lovelace
lovelaceValue = case Word64 -> Either LovelaceError Lovelace
Concrete.mkLovelace (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
value) of
      Left LovelaceError
err -> Text -> Lovelace
forall a. HasCallStack => Text -> a
panic (Text -> Lovelace) -> Text -> Lovelace
forall a b. (a -> b) -> a -> b
$ Format Text (LovelaceError -> Text) -> LovelaceError -> Text
forall a. Format Text a -> a
sformat Format Text (LovelaceError -> Text)
forall a r. Buildable a => Format r (a -> r)
build LovelaceError
err
      Right Lovelace
l -> Lovelace
l