{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Golden.ErrorsSpec
  ( test_Bech32DecodeError
  , test_InputDecodeError
  , test_JsonDecodeError
  , test_LeadershipError
  , test_OperationalCertIssueError
  , test_ProtocolParametersConversionError
  , test_ProtocolParametersError
  , test_RawBytesHexError
  , test_ScriptDataJsonBytesError
  , test_ScriptDataJsonError
  , test_ScriptDataJsonSchemaError
  , test_ScriptDataRangeError
  , test_ScriptExecutionError
  , test_StakePoolMetadataValidationError
  , test_TextEnvelopeCddlError
  , test_TextEnvelopeError
  , test_TxBodyError
  , test_TxBodyErrorAutoBalance
  , test_TxMetadataJsonError
  , test_TxMetadataRangeError
  )
where

import Cardano.Api
import Cardano.Api.Experimental.Certificate
  ( OperationalCertIssueError (..)
  , StakePoolMetadataValidationError (..)
  )

import Cardano.Binary as CBOR
import Cardano.Crypto.Seed qualified as Crypto
import Cardano.Ledger.Alonzo.Plutus.TxInfo qualified as Ledger
import Cardano.Ledger.Api.Era qualified as Ledger
import Cardano.Ledger.Binary.Decoding qualified as Binary
import Cardano.Ledger.Binary.Version
import Cardano.Ledger.Coin qualified as L
import Cardano.Ledger.Plutus.CostModels qualified as Plutus
import Cardano.Ledger.Plutus.Evaluate
import Cardano.Ledger.Plutus.ExUnits
import Cardano.Ledger.Plutus.Language qualified as Language
import PlutusCore.Evaluation.Machine.CostModelInterface qualified as Plutus
import PlutusLedgerApi.Common qualified as Plutus hiding (PlutusV2)

import Codec.Binary.Bech32 qualified as Bech32
import Control.Error.Util (hush)
import Data.Aeson qualified as Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Lazy qualified as LBS
import Data.Data
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error (UnicodeException (..))
import Data.Word
import GHC.Exts (IsList (..))
import GHC.Stack (HasCallStack)

import Test.Hedgehog.Golden.ErrorMessage qualified as ErrorMessage
import Test.Tasty

seed1 :: ByteString
seed1 =
  "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"

seed2 :: ByteString
seed2 =
  "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001"

json :: Aeson.Value
json = Aeson.String "<JSON>"

text :: Text
text = "<text>" :: Text

string :: String
string = "<string>" :: String

bytestring :: ByteString
bytestring = "<bytestring>" :: ByteString

lazyBytestring :: LBS.ByteString
lazyBytestring = "<lazy-bytestring>" :: LBS.ByteString

unicodeException :: UnicodeException
unicodeException = DecodeError "<decode error>" (Just 0xc3)

stakePoolVerKey1 :: VerificationKey StakePoolKey
stakePoolVerKey1 = getVerificationKey $ deterministicSigningKey AsStakePoolKey (Crypto.mkSeedFromBytes seed1)

stakePoolVerKey2 :: VerificationKey StakePoolKey
stakePoolVerKey2 = getVerificationKey $ deterministicSigningKey AsStakePoolKey (Crypto.mkSeedFromBytes seed2)

paymentVerKey1 :: VerificationKey PaymentKey
paymentVerKey1 = getVerificationKey $ deterministicSigningKey AsPaymentKey (Crypto.mkSeedFromBytes seed1)

txid1 :: TxId
txid1 =
  fromJust $
    hush $
      deserialiseFromRawBytesHex "210c0a4bb6391baf606843e67863d1474cc462374ab12c42d55f78a0b55b56e0"

txin1 :: TxIn
txin1 = TxIn txid1 (TxIx 1)

scriptData1 :: ScriptData
scriptData1 = ScriptDataNumber 1

scriptDataHash1 :: HashableScriptData
scriptDataHash1 = fromJust $ hush $ deserialiseFromCBOR AsHashableScriptData $ serialiseToCBOR scriptData1

hashScriptData1 :: Hash ScriptData
hashScriptData1 = hashScriptDataBytes scriptDataHash1 -- ScriptDataHash $ Ledger.unsafeMakeSafeHash hash1

scriptHash :: ScriptHash
scriptHash = hashScript $ SimpleScript $ RequireTimeBefore $ SlotNo 1

costModel :: CostModel
costModel = CostModel [0 .. 42]

changeaddr1 :: AddressInEra AllegraEra
changeaddr1 =
  AddressInEra
    (ShelleyAddressInEra ShelleyBasedEraAllegra)
    ( makeShelleyAddress
        Mainnet
        (PaymentCredentialByKey (verificationKeyHash paymentVerKey1))
        NoStakeAddress
    )

txOutValue1 :: TxOutValue AllegraEra
txOutValue1 = TxOutValueShelleyBased ShelleyBasedEraAllegra (L.Coin 1)

txout1 :: TxOut ctx AllegraEra
txout1 = TxOut changeaddr1 txOutValue1 TxOutDatumNone ReferenceScriptNone

txOutInAnyEra1 :: TxOutInAnyEra
txOutInAnyEra1 = txOutInAnyEra AllegraEra txout1

poolId :: Hash StakePoolKey
poolId =
  fromJust $
    hush $
      deserialiseFromRawBytesHex
        "9e734b6c2263c0917bfc550e9c949f41afa3fe000377243bd29df399"

test_Bech32DecodeError :: TestTree
test_Bech32DecodeError =
  testAllErrorMessages @Bech32DecodeError
    [ Bech32DecodingError Bech32.StringToDecodeTooLong
    , Bech32UnexpectedPrefix text $ Set.singleton text
    , Bech32DataPartToBytesError text
    , Bech32DeserialiseFromBytesError bytestring
    , Bech32WrongPrefix text text
    , Bech32UnexpectedHeader text text
    , Bech32InvalidUtf8 unicodeException
    ]

test_InputDecodeError :: TestTree
test_InputDecodeError =
  testAllErrorMessages @InputDecodeError
    [ InputTextEnvelopeError $ TextEnvelopeAesonDecodeError string
    , InputBech32DecodeError $ Bech32WrongPrefix text text
    , InputInvalidError
    ]

test_ProtocolParametersConversionError :: TestTree
test_ProtocolParametersConversionError =
  testAllErrorMessages @ProtocolParametersConversionError
    [ PpceOutOfBounds "pparam" 0.1
    , PpceVersionInvalid 99999
    , PpceInvalidCostModel costModel (Plutus.CMInternalWriteError string)
    , PpceMissingParameter "pparam"
    ]

test_JsonDecodeError :: TestTree
test_JsonDecodeError =
  testAllErrorMessages @JsonDecodeError
    [ JsonDecodeError string
    ]

test_LeadershipError :: TestTree
test_LeadershipError =
  testAllErrorMessages_
    "Cardano.Api.LedgerState"
    "LeadershipError"
    [ ("LeaderErrDecodeLedgerStateFailure", LeaderErrDecodeLedgerStateFailure)
    ,
      ( "LeaderErrDecodeProtocolStateFailure"
      , LeaderErrDecodeProtocolStateFailure
          ( lazyBytestring
          , CBOR.DecoderErrorVoid
          )
      )
    ,
      ( "LeaderErrDecodeProtocolEpochStateFailure"
      , LeaderErrDecodeProtocolEpochStateFailure CBOR.DecoderErrorVoid
      )
    , ("LeaderErrGenesisSlot", LeaderErrGenesisSlot)
    , ("LeaderErrStakePoolHasNoStake", LeaderErrStakePoolHasNoStake poolId)
    , ("LeaderErrStakeDistribUnstable", LeaderErrStakeDistribUnstable 1 2 3 4)
    , ("LeaderErrSlotRangeCalculationFailure", LeaderErrSlotRangeCalculationFailure text)
    , ("LeaderErrCandidateNonceStillEvolving", LeaderErrCandidateNonceStillEvolving)
    ]

test_OperationalCertIssueError :: TestTree
test_OperationalCertIssueError =
  testAllErrorMessages_
    "Cardano.Api.OperationalCertificate"
    "OperationalCertIssueError"
    [
      ( "OperationalCertKeyMismatch"
      , OperationalCertKeyMismatch
          stakePoolVerKey1
          stakePoolVerKey2
      )
    ]

test_ProtocolParametersError :: TestTree
test_ProtocolParametersError =
  testAllErrorMessages_
    "Cardano.Api.ProtocolParameters"
    "ProtocolParametersError"
    [ ("PParamsErrorMissingMinUTxoValue", PParamsErrorMissingMinUTxoValue (AnyCardanoEra ConwayEra))
    , ("PParamsErrorMissingAlonzoProtocolParameter", PParamsErrorMissingAlonzoProtocolParameter)
    ]

test_RawBytesHexError :: TestTree
test_RawBytesHexError =
  testAllErrorMessages_
    "Cardano.Api.SerialiseRaw"
    "RawBytesHexError"
    [
      ( "RawBytesHexErrorBase16DecodeFail"
      , RawBytesHexErrorBase16DecodeFail bytestring (typeRep AsTxId) string
      )
    ,
      ( "RawBytesHexErrorRawBytesDecodeFail"
      , RawBytesHexErrorRawBytesDecodeFail
          bytestring
          (typeRep (AsVerificationKey AsGenesisKey))
          (SerialiseAsRawBytesError string)
      )
    ]

test_ScriptDataJsonBytesError :: TestTree
test_ScriptDataJsonBytesError =
  testAllErrorMessages @ScriptDataJsonBytesError
    [ ScriptDataJsonBytesErrorValue $ ScriptDataJsonSchemaError Aeson.Null ScriptDataJsonNullNotAllowed
    , ScriptDataJsonBytesErrorInvalid $ ScriptDataConstructorOutOfRange 0
    ]

test_ScriptDataJsonError :: TestTree
test_ScriptDataJsonError =
  testAllErrorMessages @ScriptDataJsonError
    [ ScriptDataJsonSchemaError (Aeson.String "<JSON>") ScriptDataJsonNullNotAllowed
    , ScriptDataRangeError (Aeson.String "<JSON>") (ScriptDataConstructorOutOfRange 1)
    ]

test_ScriptDataJsonSchemaError :: TestTree
test_ScriptDataJsonSchemaError =
  testAllErrorMessages @ScriptDataJsonSchemaError
    [ ScriptDataJsonNullNotAllowed
    , ScriptDataJsonBoolNotAllowed
    , ScriptDataJsonNumberNotInteger 0.0
    , ScriptDataJsonNotObject json
    , ScriptDataJsonBadObject (replicate 5 (text, json))
    , ScriptDataJsonBadMapPair json
    , ScriptDataJsonTypeMismatch text json
    ]

test_ScriptDataRangeError :: TestTree
test_ScriptDataRangeError =
  testAllErrorMessages @ScriptDataRangeError
    [ ScriptDataConstructorOutOfRange 1
    ]

test_ScriptExecutionError :: TestTree
test_ScriptExecutionError =
  testAllErrorMessages_
    "Cardano.Api.Tx.Internal.Fee"
    "ScriptExecutionError"
    [ ("ScriptErrorMissingTxIn", ScriptErrorMissingTxIn txin1)
    , ("ScriptErrorTxInWithoutDatum", ScriptErrorTxInWithoutDatum txin1)
    , ("ScriptErrorWrongDatum", ScriptErrorWrongDatum hashScriptData1)
    ,
      ( "ScriptErrorEvaluationFailed"
      , ScriptErrorEvaluationFailed $
          DebugPlutusFailure
            Plutus.CostModelParameterMismatch
            examplePlutusWithContext
            (ExUnits 1 1)
            ["Example logs"]
      )
    , ("ScriptErrorExecutionUnitsOverflow", ScriptErrorExecutionUnitsOverflow)
    ,
      ( "ScriptErrorNotPlutusWitnessedTxIn"
      , ScriptErrorNotPlutusWitnessedTxIn (ScriptWitnessIndexTxIn 0) scriptHash
      )
    ,
      ( "ScriptErrorRedeemerPointsToUnknownScriptHash"
      , ScriptErrorRedeemerPointsToUnknownScriptHash (ScriptWitnessIndexTxIn 0)
      )
    ,
      ( "ScriptErrorMissingScript"
      , ScriptErrorMissingScript
          (ScriptWitnessIndexMint 0)
          (ResolvablePointers ShelleyBasedEraBabbage Map.empty) -- TODO CIP-1694 make work in all eras
      )
    , ("ScriptErrorMissingCostModel", ScriptErrorMissingCostModel Language.PlutusV2)
    , ("ScriptErrorTranslationError", ScriptErrorTranslationError testPastHorizonValue)
    ]

examplePlutusWithContext :: PlutusWithContext
examplePlutusWithContext =
  PlutusWithContext
    { pwcProtocolVersion = defaultVersion
    , pwcScript = Language.decodePlutusRunnable defaultVersion examplePlutusScript
    , pwcArgs = examplePlutusScriptArgs
    , pwcExUnits = ExUnits 1 1
    , pwcCostModel = defaultCostModel
    }

defaultCostModel :: Plutus.CostModel
defaultCostModel =
  fromJust
    $ Plutus.costModelFromMap
      Language.PlutusV3
    $ fromList
    $ map (,0) (Plutus.costModelParamNames Language.PlutusV3)

defaultVersion :: Version
defaultVersion = fromJust $ mkVersion @Word64 9

-- Try decoding to api's PlutusScript first then convert to ledger types
examplePlutusScript :: Language.Plutus Language.PlutusV3
examplePlutusScript =
  let cborBytes = Text.encodeUtf8 hexPlutusScriptBytes
   in case deserialiseFromRawBytes (AsPlutusScript AsPlutusScriptV3) cborBytes of
        Left e -> error $ "examplePlutusScript: Failed to decode Plutus script: " <> show e
        Right (PlutusScriptSerialised script) -> Language.Plutus $ Language.PlutusBinary script

examplePlutusScriptArgs :: Language.PlutusArgs Language.PlutusV3
examplePlutusScriptArgs =
  let cborBytes = B64.decodeLenient $ Text.encodeUtf8 base64PlutusScriptArgsBytes
   in case Binary.decodeFull' defaultVersion cborBytes of
        Left _ -> error "examplePlutusScriptArgs: Failed to decode Plutus script args"
        Right args -> args

base64PlutusScriptArgsBytes :: Text
base64PlutusScriptArgsBytes =
  "2Hmf2Hmfn9h5n9h5n1ggp4nVTEZsdm+0vF4Jy816CkYJdWfk/2BiCVVip0BLnL8A/9h5n9h5n9h6n1gcxhv6HBOFJLafN4vGlQQyLzkonOVU1UnbTR4rUP/YeoD/oUChQBoATEtA2HqfWCADFwoudZe3t+PYTAU5HROaYrFX54eG2MCC8p3PTBETFP/YeoD///+An9h5n9h5n9h5n1gcxbyvlPIHUatyym5imViDpytwsNh06mjqCXkOk//YeoD/okChQBoAHoSAWBzGG/ocE4Uktp83i8aVBDIvOSic5VTVSdtNHitQoUpNaWxsYXJDb2luBdh5gNh6gP/YeZ/YeZ/YeZ9YHMW8r5TyB1GrcspuYplYg6crcLDYdOpo6gl5DpP/2HqA/6FAoUAaAA9CQNh6n1gg7hVazpxAKSB0y2r/jJzN0nPIFkj/EUnvNrzqbruKPiX/2HqA/9h5n9h5n9h5n1gcKSM+X/Qw3SW5FG9fON4SNYYd6scERBygsGr5Ev/YeoD/oUChQBsAAA2kdfg7QNh5gNh6gP//AKFYHMYb+hwThSS2nzeLxpUEMi85KJzlVNVJ200eK1ChSk1pbGxhckNvaW4Fn9h5n9h6n1gcxhv6HBOFJLafN4vGlQQyLzkonOVU1UnbTR4rUP/YeZ8aAAYagP///6DYeZ/YeZ/YeYDYeoD/2Hmf2HuA2HqA//+Ao9h6n9h5n1ggp4nVTEZsdm+0vF4Jy816CkYJdWfk/2BiCVVip0BLnL8A//8A2HmfWBzGG/ocE4Uktp83i8aVBDIvOSic5VTVSdtNHitQ/wDYfJ8A2Hmf2HqfWBzGG/ocE4Uktp83i8aVBDIvOSic5VTVSdtNHitQ/9h5nxoABhqA////AKJYIAMXCi51l7e349hMBTkdE5pisVfnh4bYwILync9MERMUAFgg7hVazpxAKSB0y2r/jJzN0nPIFkj/EUnvNrzqbruKPiUBWCDYftkmm+fgwSsSsBQx2QwFWHhnvtoPcpBPuBHJ7A+Z0KCA2HqA2HqA/wDYfJ8A2Hmf2HqfWBzGG/ocE4Uktp83i8aVBDIvOSic5VTVSdtNHitQ/9h5nxoABhqA/////w=="

hexPlutusScriptBytes :: Text
hexPlutusScriptBytes =
  " "

test_StakePoolMetadataValidationError :: TestTree
test_StakePoolMetadataValidationError =
  testAllErrorMessages @StakePoolMetadataValidationError
    [ StakePoolMetadataJsonDecodeError string
    , StakePoolMetadataInvalidLengthError 0 1
    ]

test_TextEnvelopeCddlError :: TestTree
test_TextEnvelopeCddlError =
  testAllErrorMessages @TextEnvelopeCddlError
    [ TextEnvelopeCddlErrCBORDecodingError CBOR.DecoderErrorVoid
    , TextEnvelopeCddlAesonDecodeError string string
    , TextEnvelopeCddlUnknownKeyWitness
    , TextEnvelopeCddlTypeError [text] text
    , TextEnvelopeCddlErrUnknownType text
    , TextEnvelopeCddlErrByronKeyWitnessUnsupported
    ]

test_TextEnvelopeError :: TestTree
test_TextEnvelopeError =
  testAllErrorMessages @TextEnvelopeError
    [ TextEnvelopeTypeError [TextEnvelopeType string, TextEnvelopeType string] (TextEnvelopeType string)
    , TextEnvelopeDecodeError CBOR.DecoderErrorVoid
    , TextEnvelopeAesonDecodeError string
    , TextEnvelopeUnknownKeyWitness $ TextEnvelopeDescr string
    , TextEnvelopeUnknownType $ Text.pack string
    ]

testPastHorizonValue :: Ledger.AlonzoContextError Ledger.AlonzoEra
testPastHorizonValue = Ledger.TimeTranslationPastHorizon text

test_TxBodyError :: TestTree
test_TxBodyError =
  testAllErrorMessages_
    "Cardano.Api.Tx.Body"
    "TxBodyError"
    [ ("TxBodyEmptyTxIns", TxBodyEmptyTxIns)
    , ("TxBodyEmptyTxInsCollateral", TxBodyEmptyTxInsCollateral)
    , ("TxBodyEmptyTxOuts", TxBodyEmptyTxOuts)
    , ("TxBodyOutputNegative", TxBodyOutputError $ TxOutputNegative 1 txOutInAnyEra1)
    , ("TxBodyOutputOverflow", TxBodyOutputError $ TxOutputOverflow 1 txOutInAnyEra1)
    , ("TxBodyMetadataError", TxBodyMetadataError [(1, TxMetadataBytesTooLong 2)])
    , ("TxBodyMissingProtocolParams", TxBodyMissingProtocolParams)
    , ("TxBodyInIxOverflow", TxBodyInIxOverflow txin1)
    ]

test_TxBodyErrorAutoBalance :: TestTree
test_TxBodyErrorAutoBalance =
  testAllErrorMessages_
    "Cardano.Api.Tx.Internal.Fee"
    "TxBodyErrorAutoBalance"
    [ ("TxBodyError", TxBodyError TxBodyEmptyTxIns)
    ,
      ( "TxBodyScriptExecutionError"
      , TxBodyScriptExecutionError [(ScriptWitnessIndexTxIn 1, ScriptErrorExecutionUnitsOverflow)]
      )
    , ("TxBodyScriptBadScriptValidity", TxBodyScriptBadScriptValidity)
    , ("TxBodyErrorBalanceNegative", TxBodyErrorBalanceNegative (-1) mempty)
    , ("TxBodyErrorAdaBalanceTooSmall", TxBodyErrorAdaBalanceTooSmall txOutInAnyEra1 0 1)
    , ("TxBodyErrorMinUTxONotMet", TxBodyErrorMinUTxONotMet txOutInAnyEra1 1)
    ,
      ( "TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap"
      , TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap
          (ScriptWitnessIndexTxIn 1)
          (fromList [(ScriptWitnessIndexTxIn 2, ExecutionUnits 1 1)])
      )
    , ("TxBodyErrorCollateralInsufficient", TxBodyErrorCollateral $ InsufficientCollateral 1 2)
    ,
      ( "TxBodyErrorCollateralReturnBelowMinimumUTxO"
      , TxBodyErrorCollateral $ ReturnCollateralBelowMinimumUTxO 1 2
      )
    ,
      ( "TxBodyErrorCollateralWithoutPlutusScripts"
      , TxBodyErrorCollateral CollateralWithoutPlutusScripts
      )
    ]

test_TxMetadataJsonError :: TestTree
test_TxMetadataJsonError =
  testAllErrorMessages @TxMetadataJsonError
    [ TxMetadataJsonToplevelNotMap
    , TxMetadataJsonToplevelBadKey text
    , TxMetadataJsonSchemaError 0 json TxMetadataJsonNullNotAllowed
    , TxMetadataRangeError 0 json (TxMetadataBytesTooLong 0)
    ]

test_TxMetadataRangeError :: TestTree
test_TxMetadataRangeError =
  testAllErrorMessages @TxMetadataRangeError
    [ TxMetadataTextTooLong 0
    , TxMetadataBytesTooLong 0
    , TxMetadataNumberOutOfRange 0
    ]

goldenFilesPath :: FilePath
goldenFilesPath = "test/cardano-api-golden/files/errors"

testAllErrorMessages :: forall a. (HasCallStack, Data a, Error a) => [a] -> TestTree
testAllErrorMessages = ErrorMessage.testAllErrorMessages goldenFilesPath

testAllErrorMessages_
  :: forall a
   . (HasCallStack, Error a)
  => String
  -- ^ module name
  -> String
  -- ^ type name
  -> [(String, a)]
  -- ^ list of constructor names and values
  -> TestTree
testAllErrorMessages_ = ErrorMessage.testAllErrorMessages_ goldenFilesPath
