{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DerivingVia        #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE OverloadedStrings  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ledger.Orphans where

import Cardano.Api qualified as C
import Cardano.Crypto.Hash qualified as Hash
import Cardano.Crypto.Wallet qualified as Crypto
import Cardano.Ledger.Crypto qualified as C
import Cardano.Ledger.Hashes qualified as Hashes
import Cardano.Ledger.SafeHash qualified as C
import Codec.Serialise.Class (Serialise (..))
import Control.Monad.Freer.Extras.Log (LogLevel, LogMessage)
import Crypto.Hash qualified as Crypto
import Data.Aeson qualified as JSON
import Data.Aeson.Extras qualified as JSON
import Data.Aeson.Types qualified as JSON
import Data.Bifunctor (bimap)
import Data.ByteArray qualified as BA
import Data.Data (Data)
import Data.Hashable (Hashable)
import Data.OpenApi qualified as OpenApi
import Data.Scientific (floatingOrInteger, scientific)
import Data.Text qualified as Text
import Data.Typeable (Proxy (Proxy), Typeable)
import GHC.Generics (Generic)
import Ledger.Ada (Ada (Lovelace))
import Ledger.Crypto (PrivateKey (PrivateKey, getPrivateKey), PubKey (PubKey), Signature (Signature))
import Ledger.Scripts (Language, Versioned)
import Ledger.Slot (Slot (Slot))
import Plutus.V1.Ledger.Api (CurrencySymbol (CurrencySymbol), DCert, Extended, Interval, LedgerBytes (LedgerBytes),
                             LowerBound, MintingPolicy (MintingPolicy), MintingPolicyHash (MintingPolicyHash),
                             POSIXTime (POSIXTime), Redeemer (Redeemer), RedeemerHash (RedeemerHash), Script,
                             StakeValidator (StakeValidator), TokenName (TokenName), TxId (TxId), TxOutRef, UpperBound,
                             Validator (Validator), Value (Value), fromBytes)
import Plutus.V1.Ledger.Api qualified as PV1
import Plutus.V1.Ledger.Bytes (bytes)
import Plutus.V1.Ledger.Scripts (ScriptError, ScriptHash (..))
import Plutus.V1.Ledger.Time (DiffMilliSeconds (DiffMilliSeconds))
import Plutus.V1.Ledger.Tx (RedeemerPtr, ScriptTag)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import Plutus.V2.Ledger.Api qualified as PV2
import PlutusCore (Kind, Some, Term, Type, ValueOf, Version)
import PlutusTx.AssocMap qualified as AssocMap
import Web.HttpApiData (FromHttpApiData (parseUrlPiece), ToHttpApiData (toUrlPiece))

-- TODO: remove this dependency here once the instance of Ord for AddressInEra
-- can be obtained from upstream and removed from quickcheck-contractmodel.
import Test.QuickCheck.ContractModel.Internal.Common ()

instance ToHttpApiData PrivateKey where
    toUrlPiece :: PrivateKey -> Text
toUrlPiece = LedgerBytes -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece (LedgerBytes -> Text)
-> (PrivateKey -> LedgerBytes) -> PrivateKey -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivateKey -> LedgerBytes
getPrivateKey

instance FromHttpApiData PrivateKey where
    parseUrlPiece :: Text -> Either Text PrivateKey
parseUrlPiece Text
a = LedgerBytes -> PrivateKey
PrivateKey (LedgerBytes -> PrivateKey)
-> Either Text LedgerBytes -> Either Text PrivateKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text LedgerBytes
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
a

instance ToHttpApiData LedgerBytes where
    toUrlPiece :: LedgerBytes -> Text
toUrlPiece = ByteString -> Text
JSON.encodeByteString (ByteString -> Text)
-> (LedgerBytes -> ByteString) -> LedgerBytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerBytes -> ByteString
bytes
instance FromHttpApiData LedgerBytes where
    parseUrlPiece :: Text -> Either Text LedgerBytes
parseUrlPiece = (String -> Text)
-> (ByteString -> LedgerBytes)
-> Either String ByteString
-> Either Text LedgerBytes
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap String -> Text
Text.pack ByteString -> LedgerBytes
fromBytes (Either String ByteString -> Either Text LedgerBytes)
-> (Text -> Either String ByteString)
-> Text
-> Either Text LedgerBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String ByteString
JSON.tryDecode

-- | ByteArrayAccess instance for signing support
instance BA.ByteArrayAccess TxId where
  length :: TxId -> Int
length (TxId BuiltinByteString
bis) = BuiltinByteString -> Int
forall ba. ByteArrayAccess ba => ba -> Int
BA.length BuiltinByteString
bis
  withByteArray :: TxId -> (Ptr p -> IO a) -> IO a
withByteArray (TxId BuiltinByteString
bis) = BuiltinByteString -> (Ptr p -> IO a) -> IO a
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
BA.withByteArray BuiltinByteString
bis

-- | OpenApi instances for swagger support

deriving instance Data C.NetworkMagic
deriving instance Data C.NetworkId
deriving instance Generic C.NetworkId

instance Serialise (C.AddressInEra C.BabbageEra) where
  encode :: AddressInEra BabbageEra -> Encoding
encode = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding)
-> (AddressInEra BabbageEra -> ByteString)
-> AddressInEra BabbageEra
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInEra BabbageEra -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes
  decode :: Decoder s (AddressInEra BabbageEra)
decode = do
    ByteString
bs <- Decoder s ByteString
forall a s. Serialise a => Decoder s a
decode
    Decoder s (AddressInEra BabbageEra)
-> (AddressInEra BabbageEra -> Decoder s (AddressInEra BabbageEra))
-> Maybe (AddressInEra BabbageEra)
-> Decoder s (AddressInEra BabbageEra)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Decoder s (AddressInEra BabbageEra)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can get back Address")
      AddressInEra BabbageEra -> Decoder s (AddressInEra BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe (AddressInEra BabbageEra)
 -> Decoder s (AddressInEra BabbageEra))
-> Maybe (AddressInEra BabbageEra)
-> Decoder s (AddressInEra BabbageEra)
forall a b. (a -> b) -> a -> b
$ AsType (AddressInEra BabbageEra)
-> ByteString -> Maybe (AddressInEra BabbageEra)
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes (AsType BabbageEra -> AsType (AddressInEra BabbageEra)
forall era. AsType era -> AsType (AddressInEra era)
C.AsAddressInEra AsType BabbageEra
C.AsBabbageEra) ByteString
bs

instance OpenApi.ToSchema C.ScriptHash where
    declareNamedSchema :: Proxy ScriptHash -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ScriptHash
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ScriptHash") Schema
forall a. Monoid a => a
mempty
instance OpenApi.ToSchema (C.AddressInEra C.BabbageEra) where
    declareNamedSchema :: Proxy (AddressInEra BabbageEra)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (AddressInEra BabbageEra)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"AddressInBabbageEra") Schema
forall a. Monoid a => a
mempty
deriving instance Generic C.ScriptData
instance OpenApi.ToSchema C.ScriptData where
    declareNamedSchema :: Proxy ScriptData -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy ScriptData
_ =
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ScriptData") Schema
OpenApi.byteSchema
instance OpenApi.ToSchema (C.Hash C.ScriptData) where
    declareNamedSchema :: Proxy (Hash ScriptData) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Hash ScriptData)
_ =
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"HashScriptData") Schema
OpenApi.byteSchema
deriving instance Generic C.TxId
deriving anyclass instance OpenApi.ToSchema C.TxId
deriving instance Generic C.TxIx
deriving anyclass instance OpenApi.ToSchema C.TxIx
deriving instance Generic C.Lovelace
deriving anyclass instance OpenApi.ToSchema C.Lovelace
deriving instance Generic C.PolicyId
deriving anyclass instance OpenApi.ToSchema C.PolicyId
instance OpenApi.ToSchema C.AssetName where
    declareNamedSchema :: Proxy AssetName -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy AssetName
_ =
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"AssetName") Schema
OpenApi.byteSchema
deriving instance Generic C.Quantity
deriving anyclass instance OpenApi.ToSchema C.Quantity
deriving anyclass instance (OpenApi.ToSchema k, OpenApi.ToSchema v) => OpenApi.ToSchema (AssocMap.Map k v)
instance OpenApi.ToSchema Crypto.XPub where
    declareNamedSchema :: Proxy XPub -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy XPub
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"PubKey") Schema
forall a. Monoid a => a
mempty
instance OpenApi.ToSchema Crypto.XPrv where
    declareNamedSchema :: Proxy XPrv -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy XPrv
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"PrvKey") Schema
forall a. Monoid a => a
mempty
instance OpenApi.ToSchema (Crypto.Digest Crypto.Blake2b_160) where
    declareNamedSchema :: Proxy (Digest Blake2b_160)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Digest Blake2b_160)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Digest") Schema
forall a. Monoid a => a
mempty
instance OpenApi.ToSchema (Hash.Hash Hash.Blake2b_256 Hashes.EraIndependentTxBody) where
    declareNamedSchema :: Proxy (Hash Blake2b_256 EraIndependentTxBody)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Hash Blake2b_256 EraIndependentTxBody)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hash") Schema
forall a. Monoid a => a
mempty
instance OpenApi.ToSchema (C.SafeHash C.StandardCrypto Hashes.EraIndependentData) where
    declareNamedSchema :: Proxy (SafeHash StandardCrypto EraIndependentData)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (SafeHash StandardCrypto EraIndependentData)
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hash") Schema
forall a. Monoid a => a
mempty
deriving instance OpenApi.ToSchema (LogMessage JSON.Value)
deriving instance OpenApi.ToSchema LogLevel
instance OpenApi.ToSchema JSON.Value where
    declareNamedSchema :: Proxy Value -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Value
_ = NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JSON") Schema
forall a. Monoid a => a
mempty
deriving instance OpenApi.ToSchema ann => OpenApi.ToSchema (Kind ann)
deriving newtype instance OpenApi.ToSchema Ada
deriving instance OpenApi.ToSchema DCert
deriving instance OpenApi.ToSchema ScriptTag
deriving instance OpenApi.ToSchema RedeemerPtr
deriving instance OpenApi.ToSchema TxOutRef
deriving instance OpenApi.ToSchema PV1.TxOut
deriving instance OpenApi.ToSchema PV2.TxOut
deriving newtype instance OpenApi.ToSchema Validator
deriving newtype instance OpenApi.ToSchema TxId
deriving newtype instance OpenApi.ToSchema Slot
deriving instance OpenApi.ToSchema a => OpenApi.ToSchema (Interval a)
deriving instance OpenApi.ToSchema a => OpenApi.ToSchema (LowerBound a)
deriving instance OpenApi.ToSchema a => OpenApi.ToSchema (UpperBound a)
deriving newtype instance OpenApi.ToSchema Redeemer
deriving newtype instance OpenApi.ToSchema RedeemerHash
deriving newtype instance OpenApi.ToSchema Value
deriving newtype instance OpenApi.ToSchema MintingPolicy
deriving newtype instance OpenApi.ToSchema MintingPolicyHash
deriving newtype instance OpenApi.ToSchema CurrencySymbol
deriving newtype instance OpenApi.ToSchema PubKey
deriving newtype instance OpenApi.ToSchema TokenName
deriving newtype instance OpenApi.ToSchema StakeValidator
deriving newtype instance OpenApi.ToSchema LedgerBytes
deriving newtype instance OpenApi.ToSchema Signature
deriving newtype instance OpenApi.ToSchema POSIXTime
deriving newtype instance OpenApi.ToSchema DiffMilliSeconds
deriving newtype instance OpenApi.ToSchema AssetClass
deriving instance OpenApi.ToSchema a => OpenApi.ToSchema (Extended a)
deriving instance
    ( OpenApi.ToSchema tyname
    , OpenApi.ToSchema name
    , OpenApi.ToSchema (uni ann)
    , OpenApi.ToSchema fun
    , OpenApi.ToSchema ann
    , OpenApi.ToSchema (Type tyname uni ann)
    , OpenApi.ToSchema (Some (ValueOf uni))
    , Typeable uni
    ) => OpenApi.ToSchema (Term tyname name uni fun ann)
deriving instance OpenApi.ToSchema ann => OpenApi.ToSchema (Version ann)
instance OpenApi.ToSchema Script where
    declareNamedSchema :: Proxy Script -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Script
_ =
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
OpenApi.NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Script") (Proxy String -> Schema
forall a. ToSchema a => Proxy a -> Schema
OpenApi.toSchema (Proxy String
forall k (t :: k). Proxy t
Proxy :: Proxy String))
deriving newtype instance OpenApi.ToSchema ScriptHash
deriving instance OpenApi.ToSchema Language
deriving instance OpenApi.ToSchema script => OpenApi.ToSchema (Versioned script)

-- 'POSIXTime' instances

-- | Custom `FromJSON` instance which allows to parse a JSON number to a
-- 'POSIXTime' value. The parsed JSON value MUST be an 'Integer' or else the
-- parsing fails.
instance JSON.FromJSON POSIXTime where
  parseJSON :: Value -> Parser POSIXTime
parseJSON v :: Value
v@(JSON.Number Scientific
n) =
      (Double -> Parser POSIXTime)
-> (Integer -> Parser POSIXTime)
-> Either Double Integer
-> Parser POSIXTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Double
_ -> String -> Parser POSIXTime -> Parser POSIXTime
forall a. String -> Parser a -> Parser a
JSON.prependFailure String
"parsing POSIXTime failed, " (String -> Value -> Parser POSIXTime
forall a. String -> Value -> Parser a
JSON.typeMismatch String
"Integer" Value
v))
             (POSIXTime -> Parser POSIXTime
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> Parser POSIXTime)
-> (Integer -> POSIXTime) -> Integer -> Parser POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
POSIXTime)
             (Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n :: Either Double Integer)
  parseJSON Value
invalid =
      String -> Parser POSIXTime -> Parser POSIXTime
forall a. String -> Parser a -> Parser a
JSON.prependFailure String
"parsing POSIXTime failed, " (String -> Value -> Parser POSIXTime
forall a. String -> Value -> Parser a
JSON.typeMismatch String
"Number" Value
invalid)

-- | Custom 'ToJSON' instance which allows to simply convert a 'POSIXTime'
-- value to a JSON number.
instance JSON.ToJSON POSIXTime where
  toJSON :: POSIXTime -> Value
toJSON (POSIXTime Integer
n) = Scientific -> Value
JSON.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Scientific
scientific Integer
n Int
0

deriving newtype instance Serialise POSIXTime
deriving newtype instance Hashable POSIXTime

deriving anyclass instance JSON.ToJSON ScriptError
deriving anyclass instance JSON.FromJSON ScriptError