content: {-# LANGUAGE AllowAmbiguousTypes #-}
  {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Cardano.DbSync.Era.Universal.Insert.Tx (
    insertTx,
    insertTxOut,
  ) where
  
  import Control.Monad.Extra (mapMaybeM)
  import qualified Data.Aeson as Aeson
  import qualified Data.ByteString.Lazy.Char8 as LBS
  import qualified Data.Map.Strict as Map
  import qualified Data.Strict.Maybe as Strict
  
  import Cardano.BM.Trace (Trace)
  import qualified Cardano.Ledger.Address as Ledger
  import Cardano.Ledger.BaseTypes
  import Cardano.Ledger.Coin (Coin (..))
  import Cardano.Ledger.Mary.Value (AssetName (..), MultiAsset (..), PolicyID (..))
  import Cardano.Prelude
  
  import Cardano.Db (DbLovelace (..), DbWord64 (..))
  import qualified Cardano.Db as DB
  import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA
  import qualified Cardano.Db.Schema.Variants.TxOutCore as VC
  import Cardano.DbSync.Api
  import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), UnicodeNullSource (..))
  import Cardano.DbSync.Cache (insertAddressUsingCache, queryTxIdWithCache, tryUpdateCacheTx)
  import Cardano.DbSync.Cache.Types (CacheAction (..))
  import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
  import Cardano.DbSync.Era.Shelley.Generic.Metadata (TxMetadataValue (..), metadataValueToJsonNoSchema)
  import Cardano.DbSync.Era.Shelley.Generic.Tx.Types (TxIn (..))
  import Cardano.DbSync.Era.Universal.Insert.Certificate (insertCertificate)
  import Cardano.DbSync.Era.Universal.Insert.GovAction (
    insertGovActionProposal,
    insertParamProposal,
    insertVotingProcedures,
   )
  import Cardano.DbSync.Era.Universal.Insert.Grouped
  import Cardano.DbSync.Era.Universal.Insert.Other (
    insertDatum,
    insertExtraKeyWitness,
    insertMultiAsset,
    insertRedeemer,
    insertScript,
    insertStakeAddressRefIfMissing,
    insertWithdrawals,
   )
  import Cardano.DbSync.Era.Universal.Insert.Pool (IsPoolMember)
  import Cardano.DbSync.Era.Util (safeDecodeToJson)
  import Cardano.DbSync.Error (SyncNodeError)
  import Cardano.DbSync.Ledger.Types (ApplyResult (..), getGovExpiresAt, lookupDepositsMap)
  import Cardano.DbSync.Util
  import Cardano.DbSync.Util.Cbor (serialiseTxMetadataToCbor)
  
  --------------------------------------------------------------------------------------
  -- INSERT TX
  --------------------------------------------------------------------------------------
  insertTx ::
    SyncEnv ->
    IsPoolMember ->
    DB.BlockId ->
    EpochNo ->
    SlotNo ->
    ApplyResult ->
    Word64 ->
    Generic.Tx ->
    BlockGroupedData ->
    ExceptT SyncNodeError DB.DbM BlockGroupedData
  insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped = do
    let !txHash = Generic.txHash tx
    let !mdeposits = if not (Generic.txValidContract tx) then Just (Coin 0) else lookupDepositsMap txHash (apDepositsMap applyResult)
    let !outSum = fromIntegral $ unCoin $ Generic.txOutSum tx
        !withdrawalSum = fromIntegral $ unCoin $ Generic.txWithdrawalSum tx
        !treasuryDonation = unCoin $ Generic.txTreasuryDonation tx
        hasConsumed = getHasConsumedOrPruneTxOut syncEnv
        txIn = Generic.txInputs tx
    disInOut <- liftIO $ getDisableInOutState syncEnv
  
    -- In some txs and with specific configuration we may be able to find necessary data within the tx body.
    -- In these cases we can avoid expensive queries.
    (resolvedInputs, fees', deposits) <- case (disInOut, mdeposits, unCoin <$> Generic.txFees tx) of
      (True, _, _) -> pure ([], 0, unCoin <$> mdeposits)
      (_, Just deposits, Just fees) -> do
        resolvedInputs <- mapM (resolveTxInputs syncEnv hasConsumed False (fst <$> groupedTxOut grouped)) txIn
        let (resolvedInputs', _) = splitLast resolvedInputs
        pure (resolvedInputs', fees, Just (unCoin deposits))
      (_, Nothing, Just fees) -> do
        resolvedInputs <- mapM (resolveTxInputs syncEnv hasConsumed False (fst <$> groupedTxOut grouped)) txIn
        let (resolvedInputs', amounts) = splitLast resolvedInputs
        if any isNothing amounts
          then pure (resolvedInputs', fees, Nothing)
          else
            let !inSum = sum $ map unDbLovelace $ catMaybes amounts
             in pure (resolvedInputs', fees, Just $ fromIntegral (inSum + withdrawalSum) - fromIntegral outSum - fees - treasuryDonation)
      (_, _, Nothing) -> do
        -- Nothing in fees means a phase 2 failure
        resolvedInputs <- mapM (resolveTxInputs syncEnv hasConsumed True (fst <$> groupedTxOut grouped)) txIn
        let (resolvedInsFull, amounts) = splitLast resolvedInputs
            !inSum = sum $ map unDbLovelace $ catMaybes amounts
            !diffSum = if inSum >= outSum then inSum - outSum else 0
            !fees = maybe diffSum (fromIntegral . unCoin) (Generic.txFees tx)
        pure (resolvedInsFull, fromIntegral fees, Just 0)
  
    let fees = fromIntegral fees'
    -- Insert transaction and get txId from the DB.
    !txId <-
      lift $
        DB.insertTx $
          DB.Tx
            { DB.txHash = txHash
            , DB.txBlockId = blkId
            , DB.txBlockIndex = blockIndex
            , DB.txOutSum = DB.DbLovelace outSum
            , DB.txFee = DB.DbLovelace fees
            , DB.txDeposit = fromIntegral <$> deposits
            , DB.txSize = Generic.txSize tx
            , DB.txInvalidBefore = DbWord64 . unSlotNo <$> Generic.txInvalidBefore tx
            , DB.txInvalidHereafter = DbWord64 . unSlotNo <$> Generic.txInvalidHereafter tx
            , DB.txValidContract = Generic.txValidContract tx
            , DB.txScriptSize = sum $ Generic.txScriptSizes tx
            , DB.txTreasuryDonation = DB.DbLovelace (fromIntegral treasuryDonation)
            }
  
    tryUpdateCacheTx cache (Generic.txLedgerTxId tx) txId
    when (ioTxCBOR iopts) $ do
      void $
        lift $
          DB.insertTxCbor $
            DB.TxCbor
              { DB.txCborTxId = txId
              , DB.txCborBytes = Generic.txCBOR tx
              }
  
    if not (Generic.txValidContract tx)
      then do
        !txOutsGrouped <- mapM (insertTxOut syncEnv iopts (txId, txHash)) (Generic.txOutputs tx)
  
        let !txIns = map (prepareTxIn txId Map.empty) resolvedInputs
        -- There is a custom semigroup instance for BlockGroupedData which uses addition for the values `fees` and `outSum`.
        -- Same happens bellow on last line of this function.
        pure (grouped <> BlockGroupedData txIns txOutsGrouped [] [] fees outSum)
      else do
        -- The following operations only happen if the script passes stage 2 validation (or the tx has
        -- no script).
        !txOutsGrouped <- mapM (insertTxOut syncEnv iopts (txId, txHash)) (Generic.txOutputs tx)
  
        !redeemers <-
          Map.fromList
            <$> whenFalseMempty
              (ioPlutusExtra iopts)
              (mapM (insertRedeemer syncEnv disInOut (fst <$> groupedTxOut grouped) txId) (Generic.txRedeemer tx))
  
        when (ioPlutusExtra iopts) $ do
          mapM_ (insertDatum syncEnv txId) (Generic.txData tx)
          mapM_ (insertCollateralTxIn syncEnv tracer txId) (Generic.txCollateralInputs tx)
          mapM_ (insertReferenceTxIn syncEnv tracer txId) (Generic.txReferenceInputs tx)
          mapM_ (insertCollateralTxOut syncEnv iopts (txId, txHash)) (Generic.txCollateralOutputs tx)
  
        txMetadata <-
          whenFalseMempty (ioMetadata iopts) $
            insertTxMetadata
              syncEnv
              txId
              iopts
              (Generic.txMetadata tx)
        mapM_
          (insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers)
          $ Generic.txCertificates tx
        when (ioShelley iopts) $
          mapM_ (insertWithdrawals syncEnv txId redeemers) $
            Generic.txWithdrawals tx
        when (ioShelley iopts) $
          mapM_ (insertParamProposal blkId txId) $
            Generic.txParamProposal tx
  
        maTxMint <-
          whenFalseMempty (ioMultiAssets iopts) $
            insertMaTxMint syncEnv txId $
              Generic.txMint tx
  
        when (ioPlutusExtra iopts) $
          mapM_ (insertScript syncEnv txId) $
            Generic.txScripts tx
  
        when (ioPlutusExtra iopts) $
          mapM_ (insertExtraKeyWitness tracer txId) $
            Generic.txExtraKeyWitnesses tx
  
        when (ioGov iopts) $ do
          mapM_ (insertGovActionProposal syncEnv blkId txId (getGovExpiresAt applyResult epochNo) (apGovActionState applyResult)) $ zip [0 ..] (Generic.txProposalProcedure tx)
          mapM_ (insertVotingProcedures syncEnv blkId txId) (Generic.txVotingProcedure tx)
  
        let !txIns = map (prepareTxIn txId redeemers) resolvedInputs
        pure (grouped <> BlockGroupedData txIns txOutsGrouped txMetadata maTxMint fees outSum)
    where
      tracer = getTrace syncEnv
      cache = envCache syncEnv
      iopts = getInsertOptions syncEnv
      mDeposits = maybeFromStrict $ apDeposits applyResult
  
  --------------------------------------------------------------------------------------
  -- INSERT TXOUT
  --------------------------------------------------------------------------------------
  insertTxOut ::
    SyncEnv ->
    InsertOptions ->
    (DB.TxId, ByteString) ->
    Generic.TxOut ->
    ExceptT SyncNodeError DB.DbM (ExtendedTxOut, [MissingMaTxOut])
  insertTxOut syncEnv iopts (txId, txHash) (Generic.TxOut index addr value maMap mScript dt) = do
    mSaId <- insertStakeAddressRefIfMissing syncEnv addr
    mDatumId <-
      whenFalseEmpty (ioPlutusExtra iopts) Nothing $
        Generic.whenInlineDatum dt $
          insertDatum syncEnv txId
    mScriptId <-
      whenFalseEmpty (ioPlutusExtra iopts) Nothing $
        whenMaybe mScript $
          insertScript syncEnv txId
    !txOut <-
      case ioTxOutVariantType iopts of
        DB.TxOutVariantCore ->
          pure $
            DB.VCTxOutW $
              VC.TxOutCore
                { VC.txOutCoreAddress = addrText
                , VC.txOutCoreAddressHasScript = hasScript
                , VC.txOutCoreConsumedByTxId = Nothing
                , VC.txOutCoreDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt
                , VC.txOutCoreIndex = index
                , VC.txOutCoreInlineDatumId = mDatumId
                , VC.txOutCorePaymentCred = Generic.maybePaymentCred addr
                , VC.txOutCoreReferenceScriptId = mScriptId
                , VC.txOutCoreStakeAddressId = mSaId
                , VC.txOutCoreTxId = txId
                , VC.txOutCoreValue = Generic.coinToDbLovelace value
                }
        DB.TxOutVariantAddress -> do
          let vAddress =
                VA.Address
                  { VA.addressAddress = Generic.renderAddress addr
                  , VA.addressRaw = Ledger.serialiseAddr addr
                  , VA.addressHasScript = hasScript
                  , VA.addressPaymentCred = Generic.maybePaymentCred addr
                  , VA.addressStakeAddressId = mSaId
                  }
          addrId <- insertAddressUsingCache syncEnv UpdateCache (Ledger.serialiseAddr addr) vAddress
          pure $
            DB.VATxOutW
              (mkTxOutVariant mSaId addrId mDatumId mScriptId)
              (Just vAddress)
    -- TODO: Unsure about what we should return here for eutxo
    let !eutxo =
          case ioTxOutVariantType iopts of
            DB.TxOutVariantCore -> ExtendedTxOut txHash txOut
            DB.TxOutVariantAddress -> ExtendedTxOut txHash txOut
    !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ insertMaTxOuts syncEnv maMap
    pure (eutxo, maTxOuts)
    where
      hasScript :: Bool
      hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr)
  
      addrText :: Text
      addrText = Generic.renderAddress addr
  
      mkTxOutVariant :: Maybe DB.StakeAddressId -> DB.AddressId -> Maybe DB.DatumId -> Maybe DB.ScriptId -> VA.TxOutAddress
      mkTxOutVariant mSaId addrId mDatumId mScriptId =
        VA.TxOutAddress
          { VA.txOutAddressAddressId = addrId
          , VA.txOutAddressConsumedByTxId = Nothing
          , VA.txOutAddressDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt
          , VA.txOutAddressIndex = index
          , VA.txOutAddressInlineDatumId = mDatumId
          , VA.txOutAddressReferenceScriptId = mScriptId
          , VA.txOutAddressTxId = txId
          , VA.txOutAddressValue = Generic.coinToDbLovelace value
          , VA.txOutAddressStakeAddressId = mSaId
          }
  
  insertTxMetadata ::
    SyncEnv ->
    DB.TxId ->
    InsertOptions ->
    Maybe (Map Word64 TxMetadataValue) ->
    ExceptT SyncNodeError DB.DbM [DB.TxMetadata]
  insertTxMetadata syncEnv txId inOpts mmetadata = do
    case mmetadata of
      Nothing -> pure []
      Just metadata -> mapMaybeM prepare $ Map.toList metadata
    where
      prepare ::
        (Word64, TxMetadataValue) ->
        ExceptT SyncNodeError DB.DbM (Maybe DB.TxMetadata)
      prepare (key, md) = do
        case ioKeepMetadataNames inOpts of
          Strict.Just metadataNames -> do
            let isMatchingKey = key `elem` metadataNames
            if isMatchingKey
              then mkDbTxMetadata (key, md)
              else pure Nothing
          -- if we have TxMetadata and keepMetadataNames is Nothing then we want to keep all metadata
          Strict.Nothing -> mkDbTxMetadata (key, md)
  
      mkDbTxMetadata ::
        (Word64, TxMetadataValue) ->
        ExceptT SyncNodeError DB.DbM (Maybe DB.TxMetadata)
      mkDbTxMetadata (key, md) = do
        let jsonbs = LBS.toStrict $ Aeson.encode (metadataValueToJsonNoSchema md)
            singleKeyCBORMetadata = serialiseTxMetadataToCbor $ Map.singleton key md
        mjson <- safeDecodeToJson syncEnv PrepareTxMetadata txId jsonbs
        pure $
          Just $
            DB.TxMetadata
              { DB.txMetadataKey = DbWord64 key
              , DB.txMetadataJson = mjson
              , DB.txMetadataBytes = singleKeyCBORMetadata
              , DB.txMetadataTxId = txId
              }
  
  --------------------------------------------------------------------------------------
  -- INSERT MULTI ASSET
  --------------------------------------------------------------------------------------
  insertMaTxMint ::
    SyncEnv ->
    DB.TxId ->
    MultiAsset ->
    ExceptT SyncNodeError DB.DbM [DB.MaTxMint]
  insertMaTxMint syncEnv txId (MultiAsset mintMap) =
    concatMapM prepareOuter $ Map.toList mintMap
    where
      prepareOuter ::
        (PolicyID, Map AssetName Integer) ->
        ExceptT SyncNodeError DB.DbM [DB.MaTxMint]
      prepareOuter (policy, aMap) =
        mapM (prepareInner policy) $ Map.toList aMap
  
      prepareInner ::
        PolicyID ->
        (AssetName, Integer) ->
        ExceptT SyncNodeError DB.DbM DB.MaTxMint
      prepareInner policy (aname, amount) = do
        maId <- insertMultiAsset syncEnv policy aname
        pure $
          DB.MaTxMint
            { DB.maTxMintIdent = maId
            , DB.maTxMintQuantity = DB.integerToDbInt65 amount
            , DB.maTxMintTxId = txId
            }
  
  insertMaTxOuts ::
    SyncEnv ->
    Map PolicyID (Map AssetName Integer) ->
    ExceptT SyncNodeError DB.DbM [MissingMaTxOut]
  insertMaTxOuts syncEnv maMap =
    concatMapM prepareOuter $ Map.toList maMap
    where
      prepareOuter ::
        (PolicyID, Map AssetName Integer) ->
        ExceptT SyncNodeError DB.DbM [MissingMaTxOut]
      prepareOuter (policy, aMap) =
        mapM (prepareInner policy) $ Map.toList aMap
  
      prepareInner ::
        PolicyID ->
        (AssetName, Integer) ->
        ExceptT SyncNodeError DB.DbM MissingMaTxOut
      prepareInner policy (aname, amount) = do
        maId <- insertMultiAsset syncEnv policy aname
        pure $
          MissingMaTxOut
            { mmtoIdent = maId
            , mmtoQuantity = DbWord64 (fromIntegral amount)
            }
  
  --------------------------------------------------------------------------------------
  -- INSERT COLLATERAL
  --------------------------------------------------------------------------------------
  insertCollateralTxOut ::
    SyncEnv ->
    InsertOptions ->
    (DB.TxId, ByteString) ->
    Generic.TxOut ->
    ExceptT SyncNodeError DB.DbM ()
  insertCollateralTxOut syncEnv iopts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do
    mSaId <- insertStakeAddressRefIfMissing syncEnv addr
    mDatumId <-
      whenFalseEmpty (ioPlutusExtra iopts) Nothing $
        Generic.whenInlineDatum dt $
          insertDatum syncEnv txId
    mScriptId <-
      whenFalseEmpty (ioPlutusExtra iopts) Nothing $
        whenMaybe mScript $
          insertScript syncEnv txId
    _ <-
      case ioTxOutVariantType iopts of
        DB.TxOutVariantCore -> do
          lift $
            DB.insertCollateralTxOut $
              DB.VCCollateralTxOutW $
                VC.CollateralTxOutCore
                  { VC.collateralTxOutCoreTxId = txId
                  , VC.collateralTxOutCoreIndex = index
                  , VC.collateralTxOutCoreAddress = Generic.renderAddress addr
                  , VC.collateralTxOutCoreAddressHasScript = hasScript
                  , VC.collateralTxOutCorePaymentCred = Generic.maybePaymentCred addr
                  , VC.collateralTxOutCoreStakeAddressId = mSaId
                  , VC.collateralTxOutCoreValue = Generic.coinToDbLovelace value
                  , VC.collateralTxOutCoreDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt
                  , VC.collateralTxOutCoreMultiAssetsDescr = textShow maMap
                  , VC.collateralTxOutCoreInlineDatumId = mDatumId
                  , VC.collateralTxOutCoreReferenceScriptId = mScriptId
                  }
        DB.TxOutVariantAddress -> do
          let vAddress =
                VA.Address
                  { VA.addressAddress = Generic.renderAddress addr
                  , VA.addressRaw = Ledger.serialiseAddr addr
                  , VA.addressHasScript = hasScript
                  , VA.addressPaymentCred = Generic.maybePaymentCred addr
                  , VA.addressStakeAddressId = mSaId
                  }
          addrId <- insertAddressUsingCache syncEnv UpdateCache (Ledger.serialiseAddr addr) vAddress
          lift $
            DB.insertCollateralTxOut $
              DB.VACollateralTxOutW $
                VA.CollateralTxOutAddress
                  { VA.collateralTxOutAddressTxId = txId
                  , VA.collateralTxOutAddressIndex = index
                  , VA.collateralTxOutAddressStakeAddressId = mSaId
                  , VA.collateralTxOutAddressValue = Generic.coinToDbLovelace value
                  , VA.collateralTxOutAddressDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt
                  , VA.collateralTxOutAddressMultiAssetsDescr = textShow maMap
                  , VA.collateralTxOutAddressInlineDatumId = mDatumId
                  , VA.collateralTxOutAddressReferenceScriptId = mScriptId
                  , VA.collateralTxOutAddressAddressId = addrId
                  }
    pure ()
    where
      -- TODO: Is there any reason to add new tables for collateral multi-assets/multi-asset-outputs
      hasScript :: Bool
      hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr)
  
  insertCollateralTxIn ::
    SyncEnv ->
    Trace IO Text ->
    DB.TxId ->
    Generic.TxIn ->
    ExceptT SyncNodeError DB.DbM ()
  insertCollateralTxIn syncEnv _tracer txInId txIn = do
    eTxOutId <- queryTxIdWithCache syncEnv (txInTxId txIn)
    txOutId <- case eTxOutId of
      Right txId -> pure txId
      Left err -> liftIO $ throwIO err
    void
      . lift
      $ DB.insertCollateralTxIn
      $ DB.CollateralTxIn
        { DB.collateralTxInTxInId = txInId
        , DB.collateralTxInTxOutId = txOutId
        , DB.collateralTxInTxOutIndex = fromIntegral (txInIndex txIn)
        }
  
  insertReferenceTxIn ::
    SyncEnv ->
    Trace IO Text ->
    DB.TxId ->
    Generic.TxIn ->
    ExceptT SyncNodeError DB.DbM ()
  insertReferenceTxIn syncEnv _tracer txInId txIn = do
    etxOutId <- queryTxIdWithCache syncEnv (txInTxId txIn)
    txOutId <- case etxOutId of
      Right txId -> pure txId
      Left err -> liftIO $ throwIO err
  
    void
      . lift
      $ DB.insertReferenceTxIn
      $ DB.ReferenceTxIn
        { DB.referenceTxInTxInId = txInId
        , DB.referenceTxInTxOutId = txOutId
        , DB.referenceTxInTxOutIndex = fromIntegral (txInIndex txIn)
        }
  
  --------------------------------------------------------------------------------------
  -- Prepare TX-IN
  --------------------------------------------------------------------------------------
  prepareTxIn ::
    DB.TxId ->
    Map Word64 DB.RedeemerId ->
    (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW) ->
    ExtendedTxIn
  prepareTxIn txInId redeemers (txIn, txOutId, mTxOutId) =
    ExtendedTxIn
      { etiTxIn = txInDB
      , etiTxOutId = mTxOutId
      }
    where
      txInDB =
        DB.TxIn
          { DB.txInTxInId = txInId
          , DB.txInTxOutId = txOutId
          , DB.txInTxOutIndex = fromIntegral $ Generic.txInIndex txIn
          , DB.txInRedeemerId = mlookup (Generic.txInRedeemerIndex txIn) redeemers
          }
  