{-# 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 Codec.Serialise.Class (Serialise (..))
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.Scientific (floatingOrInteger, scientific)
import Data.Text qualified as Text
import GHC.Generics (Generic)
import Ledger.Crypto (PrivateKey (PrivateKey, getPrivateKey))
import Plutus.V1.Ledger.Api (LedgerBytes, POSIXTime (POSIXTime), TxId (TxId), fromBytes)
import Plutus.V1.Ledger.Bytes (bytes)
import Plutus.V1.Ledger.Scripts (ScriptError)
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

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

deriving instance Generic C.Lovelace
deriving instance Generic C.PolicyId
deriving instance Generic C.Quantity

-- '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