{-# 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
          { ppTxFeePolicy :: TxFeePolicy
Concrete.ppTxFeePolicy =
              TxSizeLinear -> TxFeePolicy
Concrete.TxFeePolicyTxSizeLinear
                forall a b. (a -> b) -> a -> b
$ Lovelace -> Rational -> TxSizeLinear
Concrete.TxSizeLinear
                  (forall (n :: Natural).
(KnownNat n, n <= 45000000000000000) =>
Lovelace
Concrete.mkKnownLovelace @0)
                  Rational
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
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxId -> TxId) -> (TxIn, TxOut) -> (TxIn, TxOut)
elaborateUTxOEntry TxId -> TxId
elaborateTxId)
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Map k a -> [(k, a)]
M.toList
    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 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 =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict 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)
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall b a. b -> Either a b -> b
fromRight (forall a. HasCallStack => Text -> a
panic Text
"elaborateTxBS: Error decoding TxAux")
        forall a b. (a -> b) -> a -> b
$ forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
CBOR.decodeFull Version
CBOR.byronProtVer ByteString
bytes
      where
        bytes :: ByteString
bytes = 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 = forall h. h -> Attributes h
Concrete.mkAttributes ()
    }

elaborateWitnesses :: Concrete.Tx -> [Abstract.Wit] -> Concrete.TxWitness
elaborateWitnesses :: Tx -> [Wit] -> TxWitness
elaborateWitnesses Tx
concreteTx = forall a. [a] -> Vector a
V.fromList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 forall a b. (a -> b) -> a -> b
$ VKey -> KeyPair
vKeyPair VKey
key
    signature :: TxSig
signature = 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 forall a b. (a -> b) -> a -> b
$ 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 =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => Text -> a
panic Text
"elaborateTxIns: Empty list of TxIns")
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
index)

elaborateTxOuts :: [Abstract.TxOut] -> NonEmpty Concrete.TxOut
elaborateTxOuts :: [TxOut] -> NonEmpty TxOut
elaborateTxOuts =
  forall a. a -> Maybe a -> a
fromMaybe
    ( forall a. HasCallStack => Text -> a
panic
        Text
"elaborateTxOuts: Tried to elaborate an empty list of Abstract.TxOuts"
    )
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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
          (forall a. AProtocolMagic a -> NetworkMagic
Concrete.makeNetworkMagic ProtocolMagic
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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
value) of
      Left LovelaceError
err -> forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ forall a. Format Text a -> a
sformat forall a r. Buildable a => Format r (a -> r)
build LovelaceError
err
      Right Lovelace
l -> Lovelace
l