{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeApplications   #-}

module Plutus.Blockfrost.Utils where

import Data.Maybe (fromJust, fromMaybe)
import Data.Proxy (Proxy (..))
import Data.String
import Data.Text (Text, pack, unpack)
import Data.Text qualified as Text (drop, take)
import Text.Hex (decodeHex, encodeHex)
import Text.Read (readMaybe)

import Blockfrost.Client as Blockfrost
import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as Api
import Ledger.Slot qualified as Ledger (Slot (..), SlotRange)
import Ledger.Tx (TxOutRef (..))
import Ledger.Tx qualified as LT (ScriptTag (..))
import Ledger.Tx.CardanoAPI hiding (fromCardanoAddressInEra)
import Ledger.Value.CardanoAPI qualified as Value
import Money (Approximation (Round), DecimalConf (..), SomeDiscrete, UnitScale, defaultDecimalConf, discreteToDecimal,
              scale, someDiscreteAmount, someDiscreteCurrency)
import Plutus.V1.Ledger.Address qualified as LA
import Plutus.V1.Ledger.Api (Credential (..), TxId (TxId), fromBuiltin, toBuiltin, unCurrencySymbol, unTokenName)
import Plutus.V1.Ledger.Api qualified (DatumHash, RedeemerHash)
import Plutus.V1.Ledger.Interval (always, from, interval, to)
import Plutus.V1.Ledger.Scripts qualified as PS
import Plutus.V1.Ledger.Value (AssetClass, unAssetClass)


class Show a => ToBlockfrostScriptHash a where
  toBlockfrostScriptHash :: a -> Blockfrost.ScriptHash
  toBlockfrostScriptHash = String -> ScriptHash
forall a. IsString a => String -> a
fromString (String -> ScriptHash) -> (a -> String) -> a -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

instance ToBlockfrostScriptHash PS.ValidatorHash
instance ToBlockfrostScriptHash PS.MintingPolicyHash
instance ToBlockfrostScriptHash PS.StakeValidatorHash

class Show a => ToBlockfrostDatumHash a where
  toBlockfrostDatumHash :: a -> Blockfrost.DatumHash
  toBlockfrostDatumHash = String -> DatumHash
forall a. IsString a => String -> a
fromString (String -> DatumHash) -> (a -> String) -> a -> DatumHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

instance ToBlockfrostDatumHash Plutus.V1.Ledger.Api.DatumHash
instance ToBlockfrostDatumHash Plutus.V1.Ledger.Api.RedeemerHash

toBlockfrostTxHash :: TxId -> TxHash
toBlockfrostTxHash :: TxId -> TxHash
toBlockfrostTxHash = Text -> TxHash
TxHash (Text -> TxHash) -> (TxId -> Text) -> TxId -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (TxId -> String) -> TxId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> String
forall a. Show a => a -> String
show

toBlockfrostTxHashes :: [TxId] -> [TxHash]
toBlockfrostTxHashes :: [TxId] -> [TxHash]
toBlockfrostTxHashes = (TxId -> TxHash) -> [TxId] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map TxId -> TxHash
toBlockfrostTxHash

toBlockfrostRef :: TxOutRef -> (TxHash, Integer)
toBlockfrostRef :: TxOutRef -> (TxHash, Integer)
toBlockfrostRef TxOutRef
ref = (TxId -> TxHash
toBlockfrostTxHash (TxOutRef -> TxId
txOutRefId TxOutRef
ref), TxOutRef -> Integer
txOutRefIdx TxOutRef
ref)

toBlockfrostAssetId :: AssetClass -> AssetId
toBlockfrostAssetId :: AssetClass -> AssetId
toBlockfrostAssetId AssetClass
ac = String -> AssetId
forall a. IsString a => String -> a
fromString (String
polId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tName)
  where
    (CurrencySymbol
cs, TokenName
tn) = AssetClass -> (CurrencySymbol, TokenName)
unAssetClass AssetClass
ac

    polId :: String
    polId :: String
polId = (Text -> String
unpack (Text -> String)
-> (CurrencySymbol -> Text) -> CurrencySymbol -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeHex (ByteString -> Text)
-> (CurrencySymbol -> ByteString) -> CurrencySymbol -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (BuiltinByteString -> ByteString)
-> (CurrencySymbol -> BuiltinByteString)
-> CurrencySymbol
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencySymbol -> BuiltinByteString
unCurrencySymbol) CurrencySymbol
cs

    tName :: String
    tName :: String
tName = (Text -> String
unpack (Text -> String) -> (TokenName -> Text) -> TokenName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeHex (ByteString -> Text)
-> (TokenName -> ByteString) -> TokenName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (BuiltinByteString -> ByteString)
-> (TokenName -> BuiltinByteString) -> TokenName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenName -> BuiltinByteString
unTokenName) TokenName
tn

textToDatumHash :: Text -> PS.DatumHash
textToDatumHash :: Text -> DatumHash
textToDatumHash = BuiltinByteString -> DatumHash
PS.DatumHash (BuiltinByteString -> DatumHash)
-> (Text -> BuiltinByteString) -> Text -> DatumHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (Text -> ByteString) -> Text -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString)
-> (Text -> Maybe ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex

textToScriptHash :: Text -> PS.ScriptHash
textToScriptHash :: Text -> ScriptHash
textToScriptHash = BuiltinByteString -> ScriptHash
PS.ScriptHash (BuiltinByteString -> ScriptHash)
-> (Text -> BuiltinByteString) -> Text -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (Text -> ByteString) -> Text -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString)
-> (Text -> Maybe ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex

textToRedeemerHash :: Text -> PS.RedeemerHash
textToRedeemerHash :: Text -> RedeemerHash
textToRedeemerHash = BuiltinByteString -> RedeemerHash
PS.RedeemerHash (BuiltinByteString -> RedeemerHash)
-> (Text -> BuiltinByteString) -> Text -> RedeemerHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (Text -> ByteString) -> Text -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString)
-> (Text -> Maybe ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex

toPlutusScriptTag :: ValidationPurpose -> LT.ScriptTag
toPlutusScriptTag :: ValidationPurpose -> ScriptTag
toPlutusScriptTag = \case
    ValidationPurpose
Spend  -> ScriptTag
LT.Spend
    ValidationPurpose
Mint   -> ScriptTag
LT.Mint
    ValidationPurpose
Cert   -> ScriptTag
LT.Cert
    ValidationPurpose
Reward -> ScriptTag
LT.Reward

toCardanoAddress :: Blockfrost.Address -> Either String (C.AddressInEra C.BabbageEra)
toCardanoAddress :: Address -> Either String (AddressInEra BabbageEra)
toCardanoAddress Address
bAddr = case Maybe (Address ShelleyAddr)
deserialized of
    Maybe (Address ShelleyAddr)
Nothing  -> String -> Either String (AddressInEra BabbageEra)
forall a b. a -> Either a b
Left String
"Error deserializing the Address"
    Just Address ShelleyAddr
des -> AddressInEra BabbageEra -> Either String (AddressInEra BabbageEra)
forall a b. b -> Either a b
Right (AddressInEra BabbageEra
 -> Either String (AddressInEra BabbageEra))
-> AddressInEra BabbageEra
-> Either String (AddressInEra BabbageEra)
forall a b. (a -> b) -> a -> b
$ Address ShelleyAddr -> AddressInEra BabbageEra
forall era.
IsShelleyBasedEra era =>
Address ShelleyAddr -> AddressInEra era
C.shelleyAddressInEra Address ShelleyAddr
des
  where
    deserialized :: Maybe (Api.Address C.ShelleyAddr)
    deserialized :: Maybe (Address ShelleyAddr)
deserialized = AsType (Address ShelleyAddr) -> Text -> Maybe (Address ShelleyAddr)
forall addr.
SerialiseAddress addr =>
AsType addr -> Text -> Maybe addr
C.deserialiseAddress AsType (Address ShelleyAddr)
C.AsShelleyAddress (Address -> Text
unAddress Address
bAddr)

fromCardanoAddressInEra :: C.AddressInEra C.BabbageEra -> Blockfrost.Address
fromCardanoAddressInEra :: AddressInEra BabbageEra -> Address
fromCardanoAddressInEra = Text -> Address
mkAddress (Text -> Address)
-> (AddressInEra BabbageEra -> Text)
-> AddressInEra BabbageEra
-> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInEra BabbageEra -> Text
forall addr. SerialiseAddress addr => addr -> Text
C.serialiseAddress

credentialToAddress :: C.NetworkId -> Credential -> Blockfrost.Address
credentialToAddress :: NetworkId -> Credential -> Address
credentialToAddress NetworkId
netId Credential
c = case NetworkId
-> Address -> Either ToCardanoError (AddressInEra BabbageEra)
toCardanoAddressInEra NetworkId
netId Address
pAddress of
    Left ToCardanoError
err   -> String -> Address
forall a. HasCallStack => String -> a
error (String -> Address) -> String -> Address
forall a b. (a -> b) -> a -> b
$ ToCardanoError -> String
forall a. Show a => a -> String
show ToCardanoError
err
    Right AddressInEra BabbageEra
addr -> AddressInEra BabbageEra -> Address
fromCardanoAddressInEra AddressInEra BabbageEra
addr
  where
    pAddress :: LA.Address
    pAddress :: Address
pAddress = case Credential
c of
      PubKeyCredential PubKeyHash
pkh     -> PubKeyHash -> Address
LA.pubKeyHashAddress PubKeyHash
pkh
      ScriptCredential ValidatorHash
valHash -> ValidatorHash -> Address
LA.scriptHashAddress ValidatorHash
valHash

txHashToTxId :: TxHash -> TxId
txHashToTxId :: TxHash -> TxId
txHashToTxId = BuiltinByteString -> TxId
TxId (BuiltinByteString -> TxId)
-> (TxHash -> BuiltinByteString) -> TxHash -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> (TxHash -> ByteString) -> TxHash -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString)
-> (TxHash -> Maybe ByteString) -> TxHash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex (Text -> Maybe ByteString)
-> (TxHash -> Text) -> TxHash -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxHash -> Text
unTxHash

utxoToRef :: AddressUtxo -> TxOutRef
utxoToRef :: AddressUtxo -> TxOutRef
utxoToRef AddressUtxo
utxo = TxOutRef :: TxId -> Integer -> TxOutRef
TxOutRef { txOutRefId :: TxId
txOutRefId=AddressUtxo -> TxId
utxoToTxId AddressUtxo
utxo
                          , txOutRefIdx :: Integer
txOutRefIdx=AddressUtxo -> Integer
_addressUtxoOutputIndex AddressUtxo
utxo
                          }

utxoToTxId :: AddressUtxo -> TxId
utxoToTxId :: AddressUtxo -> TxId
utxoToTxId = TxHash -> TxId
txHashToTxId (TxHash -> TxId) -> (AddressUtxo -> TxHash) -> AddressUtxo -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressUtxo -> TxHash
_addressUtxoTxHash

txoToRef :: UtxoInput -> TxOutRef
txoToRef :: UtxoInput -> TxOutRef
txoToRef UtxoInput
txo = TxOutRef :: TxId -> Integer -> TxOutRef
TxOutRef { txOutRefId :: TxId
txOutRefId=UtxoInput -> TxId
txoToTxId UtxoInput
txo
                        , txOutRefIdx :: Integer
txOutRefIdx=UtxoInput -> Integer
_utxoInputOutputIndex UtxoInput
txo
                        }

-- We are forced to use blockfrost-client v0.3.1 by the cardano-wallet.
-- In that version, _utxoInputTxHash returns a Text instead of a TxHash
txoToTxId :: UtxoInput -> TxId
txoToTxId :: UtxoInput -> TxId
txoToTxId = TxHash -> TxId
txHashToTxId (TxHash -> TxId) -> (UtxoInput -> TxHash) -> UtxoInput -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoInput -> TxHash
_utxoInputTxHash

amountsToValue :: [Blockfrost.Amount] -> C.Value
amountsToValue :: [Amount] -> Value
amountsToValue = (Amount -> Value) -> [Amount] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Amount -> Value
blfAmountToValue

blfAmountToValue :: Blockfrost.Amount -> C.Value
blfAmountToValue :: Amount -> Value
blfAmountToValue Amount
amt = case Amount
amt of
                          AdaAmount Lovelaces
lov  -> Lovelaces -> Value
lovelacesToValue Lovelaces
lov
                          AssetAmount SomeDiscrete
ds -> SomeDiscrete -> Value
discreteCurrencyToValue SomeDiscrete
ds

discreteCurrencyToValue :: Money.SomeDiscrete -> C.Value
discreteCurrencyToValue :: SomeDiscrete -> Value
discreteCurrencyToValue SomeDiscrete
sd = PolicyId -> AssetName -> Integer -> Value
Value.singleton PolicyId
pid AssetName
an Integer
quant
  where
    pid :: C.PolicyId
    pid :: PolicyId
pid = String -> PolicyId
forall a. IsString a => String -> a
fromString (String -> PolicyId) -> String -> PolicyId
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.take Int
56 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SomeDiscrete -> Text
someDiscreteCurrency SomeDiscrete
sd

    an :: C.AssetName
    an :: AssetName
an =  ByteString -> AssetName
C.AssetName (ByteString -> AssetName) -> ByteString -> AssetName
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ByteString
decodeHex (Text -> Maybe ByteString) -> Text -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
56 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SomeDiscrete -> Text
someDiscreteCurrency SomeDiscrete
sd

    quant :: Integer
    quant :: Integer
quant = SomeDiscrete -> Integer
someDiscreteAmount SomeDiscrete
sd

lovelaceConfig :: Money.DecimalConf
lovelaceConfig :: DecimalConf
lovelaceConfig = DecimalConf
Money.defaultDecimalConf
  { decimalConf_digits :: Word8
Money.decimalConf_digits = Word8
0
  , decimalConf_scale :: Scale
Money.decimalConf_scale =
        Proxy '(1000000, 1) -> Scale
forall (proxy :: (Nat, Nat) -> *) (scale :: (Nat, Nat)).
GoodScale scale =>
proxy scale -> Scale
Money.scale (Proxy (UnitScale "ADA" "lovelace")
forall k (t :: k). Proxy t
Proxy @(Money.UnitScale "ADA" "lovelace"))
  }

lovelacesToMInt :: Lovelaces -> Maybe Integer
lovelacesToMInt :: Lovelaces -> Maybe Integer
lovelacesToMInt = String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Integer)
-> (Discrete' "ADA" '(1000000, 1) -> String)
-> Discrete' "ADA" '(1000000, 1)
-> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String)
-> (Discrete' "ADA" '(1000000, 1) -> Text)
-> Discrete' "ADA" '(1000000, 1)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecimalConf
-> Approximation -> Discrete' "ADA" '(1000000, 1) -> Text
forall (scale :: (Nat, Nat)) (currency :: Symbol).
GoodScale scale =>
DecimalConf -> Approximation -> Discrete' currency scale -> Text
Money.discreteToDecimal DecimalConf
lovelaceConfig Approximation
Money.Round

lovelacesToValue :: Lovelaces -> C.Value
lovelacesToValue :: Lovelaces -> Value
lovelacesToValue = Integer -> Value
Value.lovelaceValueOf (Integer -> Value)
-> (Discrete' "ADA" '(1000000, 1) -> Integer)
-> Discrete' "ADA" '(1000000, 1)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (Maybe Integer -> Integer)
-> (Discrete' "ADA" '(1000000, 1) -> Maybe Integer)
-> Discrete' "ADA" '(1000000, 1)
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Discrete' "ADA" '(1000000, 1) -> Maybe Integer
Lovelaces -> Maybe Integer
lovelacesToMInt

textToSlot :: Text -> Ledger.Slot
textToSlot :: Text -> Slot
textToSlot = Slot -> (Integer -> Slot) -> Maybe Integer -> Slot
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Slot
forall a. HasCallStack => String -> a
error String
"Failed to convert text to slot") Integer -> Slot
Ledger.Slot (Maybe Integer -> Slot) -> (Text -> Maybe Integer) -> Text -> Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Integer)
-> (Text -> String) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)

-- the functions "to", "from" and "interval" includes the parameters inside the validity range, meanwhile
-- blockfrost gives us an [) range, so we need to take one from the Right bound
toPlutusSlotRange :: Maybe Text -> Maybe Text -> Ledger.SlotRange
toPlutusSlotRange :: Maybe Text -> Maybe Text -> SlotRange
toPlutusSlotRange Maybe Text
Nothing Maybe Text
Nothing            = SlotRange
forall a. Interval a
always
toPlutusSlotRange Maybe Text
Nothing (Just Text
after)       = Slot -> SlotRange
forall a. a -> Interval a
to (Text -> Slot
textToSlot Text
after Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
- Slot
1)
toPlutusSlotRange (Just Text
before) Maybe Text
Nothing      = Slot -> SlotRange
forall a. a -> Interval a
from (Text -> Slot
textToSlot Text
before)
toPlutusSlotRange (Just Text
before) (Just Text
after) = Slot -> Slot -> SlotRange
forall a. a -> a -> Interval a
interval (Text -> Slot
textToSlot Text
before) (Text -> Slot
textToSlot Text
after Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
- Slot
1)