-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Minting image tokens.
--
-----------------------------------------------------------------------------


{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}


module Pigy.Chain.Mint (
-- * Minting
  mint
-- * Validation
,  checkValue
-- * Filtering
, pigFilter
, findPigs
) where


import Cardano.Api                                       (AssetId(..), AssetName(..), PolicyId(..), Quantity(..), ScriptHash, ShelleyWitnessSigningKey(..), TxIn(..), TxMetadata(..), TxMetadataValue(..), TxOut(..), TxOutValue(..), Value, filterValue, getTxId, makeScriptWitness, makeShelleyKeyWitness, makeSignedTransaction, makeTransactionBody, negateValue, quantityToLovelace, selectAsset, selectLovelace, serialiseToRawBytesHexText, valueFromList, valueToList)
import Control.Monad.Error.Class                         (throwError)
import Control.Monad.IO.Class                            (MonadIO, liftIO)
import Data.Maybe                                        (mapMaybe)
import Mantis.Query                                      (submitTransaction)
import Mantis.Script                                     (mintingScript)
import Mantis.Transaction                                (includeFee, makeTransaction, supportedMultiAsset)
import Mantis.Types                                      (MantisM, foistMantisEither, printMantis)
import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult(..))
import Pigy.Chain.Types                                  (MaryAddress)
import Pigy.Image                                        (crossover, fromChromosome, newGenotype)
import Pigy.Ipfs                                         (pinImage)
import Pigy.Types                                        (Context(..), KeyedAddress(..))

import qualified Data.ByteString.Char8 as BS (ByteString, drop, isPrefixOf, pack, unpack)
import qualified Data.Map.Strict       as M  (fromList)
import qualified Data.Text             as T  (pack)


-- | Validate input value.
checkValue :: AssetId    -- ^ The payment token.
           -> ScriptHash -- ^ The policy for the image tokens.
           -> Value      -- ^ The value to be validated.
           -> Bool       -- ^ Whether minting can proceed.
checkValue :: AssetId -> ScriptHash -> Value -> Bool
checkValue AssetId
token ScriptHash
scriptHash Value
value =
  let
    ada :: Lovelace
ada = Value -> Lovelace
selectLovelace Value
value
    pigy :: Quantity
pigy = Value -> AssetId -> Quantity
selectAsset Value
value AssetId
token
    pigs :: Int
pigs = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum[Int
1, [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ByteString] -> Int) -> [ByteString] -> Int
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Value -> [ByteString]
findPigs ScriptHash
scriptHash Value
value]
    a :: Integer
a = Integer
1_500_000
    b :: Integer
b =   Integer
500_000
  in
    Quantity
pigy Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity
0 Bool -> Bool -> Bool
&& Lovelace
ada Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Quantity -> Lovelace
quantityToLovelace (Integer -> Quantity
Quantity (Integer -> Quantity) -> Integer -> Quantity
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pigs)


-- | Test whether an asset is a token image.
pigFilter :: ScriptHash -- ^ The policy for the image tokens.
          -> AssetId    -- ^ The asset in question.
          -> Bool       -- ^ Whether the asset is an image token.
pigFilter :: ScriptHash -> AssetId -> Bool
pigFilter ScriptHash
scriptHash (AssetId (PolicyId ScriptHash
scriptHash') (AssetName ByteString
name')) = ScriptHash
scriptHash' ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
scriptHash Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
"PIG@" ByteString
name'
pigFilter ScriptHash
_ AssetId
_ = Bool
False


-- | Find the tickers for the image tokens in a value.
findPigs :: ScriptHash      -- ^ The policy.
         -> Value           -- ^ The value.
         -> [BS.ByteString] -- ^ The image-token tickers.
findPigs :: ScriptHash -> Value -> [ByteString]
findPigs ScriptHash
scriptHash =
  ((AssetId, Quantity) -> ByteString)
-> [(AssetId, Quantity)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(AssetId PolicyId
_ (AssetName ByteString
name'), Quantity
_) -> Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
name')
    ([(AssetId, Quantity)] -> [ByteString])
-> (Value -> [(AssetId, Quantity)]) -> Value -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ScriptHash -> AssetId -> Bool
pigFilter ScriptHash
scriptHash (AssetId -> Bool)
-> ((AssetId, Quantity) -> AssetId) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> AssetId
forall a b. (a, b) -> a
fst)
    ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList


-- | Mint or burn an image token.
mint :: MonadFail m
     => MonadIO m
     => Context      -- ^ The service context.
     -> [TxIn]       -- ^ The UTxOs to be spent.
     -> MaryAddress  -- ^ The destination.
     -> Value        -- ^ The value to be spent.
     -> [String]     -- ^ The message to be embedded in the transaction.
     -> MantisM m () -- ^ The action to mint or burn.
mint :: Context
-> [TxIn] -> MaryAddress -> Value -> [String] -> MantisM m ()
mint Context{Bool
String
IOGenM StdGen
ConsensusModeParams CardanoMode
NetworkId
AssetId
ProtocolParameters
KeyedAddress
Mode
verbose :: Context -> Bool
operation :: Context -> Mode
images :: Context -> String
ipfsPin :: Context -> String
gRandom :: Context -> IOGenM StdGen
keyedAddress :: Context -> KeyedAddress
token :: Context -> AssetId
pparams :: Context -> ProtocolParameters
network :: Context -> NetworkId
protocol :: Context -> ConsensusModeParams CardanoMode
socket :: Context -> String
verbose :: Bool
operation :: Mode
images :: String
ipfsPin :: String
gRandom :: IOGenM StdGen
keyedAddress :: KeyedAddress
token :: AssetId
pparams :: ProtocolParameters
network :: NetworkId
protocol :: ConsensusModeParams CardanoMode
socket :: String
..} [TxIn]
txIns MaryAddress
destination Value
value [String]
message =
  do
    let
      KeyedAddress{SomePaymentVerificationKey
MaryAddress
Hash PaymentKey
SigningKey PaymentExtendedKey
signing :: KeyedAddress -> SigningKey PaymentExtendedKey
verification :: KeyedAddress -> SomePaymentVerificationKey
verificationHash :: KeyedAddress -> Hash PaymentKey
keyAddress :: KeyedAddress -> MaryAddress
signing :: SigningKey PaymentExtendedKey
verification :: SomePaymentVerificationKey
verificationHash :: Hash PaymentKey
keyAddress :: MaryAddress
..} = KeyedAddress
keyedAddress
      (ScriptInEra MaryEra
script, ScriptHash
scriptHash) = Hash PaymentKey
-> Maybe SlotNo -> (ScriptInEra MaryEra, ScriptHash)
mintingScript Hash PaymentKey
verificationHash Maybe SlotNo
forall a. Maybe a
Nothing
      pigs :: [ByteString]
pigs = ScriptHash -> Value -> [ByteString]
findPigs ScriptHash
scriptHash Value
value
    (Maybe TxMetadata
metadata, Value
minting) <-
      if [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
pigs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        then do
               String -> MantisM m ()
forall (m :: * -> *). MonadIO m => String -> MantisM m ()
printMantis (String -> MantisM m ()) -> String -> MantisM m ()
forall a b. (a -> b) -> a -> b
$ String
"  Burnt token: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS.unpack ([ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
pigs)
               (Maybe TxMetadata, Value) -> MantisM m (Maybe TxMetadata, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return
                 (
                   Maybe TxMetadata
forall a. Maybe a
Nothing
                 , Value -> Value
negateValue (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ (AssetId -> Bool) -> Value -> Value
filterValue (ScriptHash -> AssetId -> Bool
pigFilter ScriptHash
scriptHash) Value
value
                 )
        else do
               Genotype
genotype <-
                 IO Genotype -> MantisM m Genotype
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                   (IO Genotype -> MantisM m Genotype)
-> IO Genotype -> MantisM m Genotype
forall a b. (a -> b) -> a -> b
$ if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
pigs
                       then do
                              String -> IO ()
putStrLn String
"  New token."
                              IOGenM StdGen -> IO Genotype
forall g. StatefulGen g IO => g -> IO Genotype
newGenotype IOGenM StdGen
gRandom
                       else do
                              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  Crossover token: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (ByteString -> String
BS.unpack (ByteString -> String) -> [ByteString] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
pigs)
                              IOGenM StdGen -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover IOGenM StdGen
gRandom ([Genotype] -> IO Genotype) -> [Genotype] -> IO Genotype
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe Genotype) -> [ByteString] -> [Genotype]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Genotype
fromChromosome (String -> Maybe Genotype)
-> (ByteString -> String) -> ByteString -> Maybe Genotype
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack) [ByteString]
pigs
               (String
chromosome, String
cid) <- String -> String -> Genotype -> MantisM m (String, String)
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
String -> String -> Genotype -> MantisM m (String, String)
pinImage String
ipfsPin String
images Genotype
genotype
               let
                 name :: String
name = String
"PIG@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chromosome
               (Maybe TxMetadata, Value) -> MantisM m (Maybe TxMetadata, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return
                 (
                   TxMetadata -> Maybe TxMetadata
forall a. a -> Maybe a
Just
                     (TxMetadata -> Maybe TxMetadata)
-> (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue
-> Maybe TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 TxMetadataValue -> TxMetadata
TxMetadata
                     (Map Word64 TxMetadataValue -> Maybe TxMetadata)
-> Map Word64 TxMetadataValue -> Maybe TxMetadata
forall a b. (a -> b) -> a -> b
$ [(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                     [
                       (
                         Word64
721
                       , [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
                         [
                           (
                             Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue)
-> (ScriptHash -> Text) -> ScriptHash -> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText (ScriptHash -> TxMetadataValue) -> ScriptHash -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ ScriptHash
scriptHash
                           , [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
                             [
                               (
                                 Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
name
                               , [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
                                 [
                                   (Text -> TxMetadataValue
TxMetaText Text
"name"      , Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue)
-> (String -> Text) -> String -> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> TxMetadataValue) -> String -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ String
"PIG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chromosome                         )
                                 , (Text -> TxMetadataValue
TxMetaText Text
"image"     , Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text
"ipfs://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
cid                               )
                                 , (Text -> TxMetadataValue
TxMetaText Text
"ticker"    , Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
name                                           )
                                 , (Text -> TxMetadataValue
TxMetaText Text
"parents"   , [TxMetadataValue] -> TxMetadataValue
TxMetaList ([TxMetadataValue] -> TxMetadataValue)
-> [TxMetadataValue] -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue)
-> (ByteString -> Text) -> ByteString -> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ByteString -> String) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"PIG@" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack (ByteString -> TxMetadataValue)
-> [ByteString] -> [TxMetadataValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
pigs)
                                 , (Text -> TxMetadataValue
TxMetaText Text
"url"       , Text -> TxMetadataValue
TxMetaText Text
"https://pigy.functionally.live"                        )
                                 ]
                               )
                             ]
                           )
                         ]
                       )
                     , (
                         Word64
674
                       , [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
                         [
                           (
                             Text -> TxMetadataValue
TxMetaText Text
"msg"
                           , [TxMetadataValue] -> TxMetadataValue
TxMetaList ([TxMetadataValue] -> TxMetadataValue)
-> [TxMetadataValue] -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue)
-> (String -> Text) -> String -> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> TxMetadataValue) -> [String] -> [TxMetadataValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
message
                           )
                         ]
                       )
                     ]
                 , [(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId (ScriptHash -> PolicyId
PolicyId ScriptHash
scriptHash) (ByteString -> AssetName
AssetName (ByteString -> AssetName) -> ByteString -> AssetName
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
name),  Quantity
1)]
                 )
    let
      value' :: Value
value' = Value
value Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
minting
    TxBodyContent MaryEra
txBody <- NetworkId
-> ProtocolParameters
-> Int
-> Int
-> Int
-> Int
-> TxBodyContent MaryEra
-> MantisM m (TxBodyContent MaryEra)
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
NetworkId
-> ProtocolParameters
-> Int
-> Int
-> Int
-> Int
-> TxBodyContent MaryEra
-> MantisM m (TxBodyContent MaryEra)
includeFee NetworkId
network ProtocolParameters
pparams Int
1 Int
1 Int
1 Int
0
      (TxBodyContent MaryEra -> MantisM m (TxBodyContent MaryEra))
-> TxBodyContent MaryEra -> MantisM m (TxBodyContent MaryEra)
forall a b. (a -> b) -> a -> b
$ [TxIn]
-> [TxOut MaryEra]
-> Maybe SlotNo
-> Maybe TxMetadata
-> Maybe (ScriptInEra MaryEra)
-> Maybe Value
-> TxBodyContent MaryEra
makeTransaction
        [TxIn]
txIns
        [MaryAddress -> TxOutValue MaryEra -> TxOut MaryEra
forall era. AddressInEra era -> TxOutValue era -> TxOut era
TxOut MaryAddress
destination (MultiAssetSupportedInEra MaryEra -> Value -> TxOutValue MaryEra
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
TxOutValue MultiAssetSupportedInEra MaryEra
supportedMultiAsset Value
value')]
        Maybe SlotNo
forall a. Maybe a
Nothing
        Maybe TxMetadata
metadata
        Maybe (ScriptInEra MaryEra)
forall a. Maybe a
Nothing
        (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
minting)
    TxBody MaryEra
txRaw <- Either (TxBodyError MaryEra) (TxBody MaryEra)
-> MantisM m (TxBody MaryEra)
forall (m :: * -> *) e a.
(Monad m, Show e) =>
Either e a -> MantisM m a
foistMantisEither (Either (TxBodyError MaryEra) (TxBody MaryEra)
 -> MantisM m (TxBody MaryEra))
-> Either (TxBodyError MaryEra) (TxBody MaryEra)
-> MantisM m (TxBody MaryEra)
forall a b. (a -> b) -> a -> b
$ TxBodyContent MaryEra
-> Either (TxBodyError MaryEra) (TxBody MaryEra)
forall era.
IsCardanoEra era =>
TxBodyContent era -> Either (TxBodyError era) (TxBody era)
makeTransactionBody TxBodyContent MaryEra
txBody
    let
      witness :: Witness MaryEra
witness = TxBody MaryEra -> ShelleyWitnessSigningKey -> Witness MaryEra
forall era.
IsShelleyBasedEra era =>
TxBody era -> ShelleyWitnessSigningKey -> Witness era
makeShelleyKeyWitness TxBody MaryEra
txRaw
        (ShelleyWitnessSigningKey -> Witness MaryEra)
-> ShelleyWitnessSigningKey -> Witness MaryEra
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentExtendedKey -> ShelleyWitnessSigningKey
WitnessPaymentExtendedKey SigningKey PaymentExtendedKey
signing
      witness' :: Witness MaryEra
witness' = ScriptInEra MaryEra -> Witness MaryEra
forall era. ScriptInEra era -> Witness era
makeScriptWitness ScriptInEra MaryEra
script
      txSigned :: Tx MaryEra
txSigned = [Witness MaryEra] -> TxBody MaryEra -> Tx MaryEra
forall era. [Witness era] -> TxBody era -> Tx era
makeSignedTransaction [Witness MaryEra
witness, Witness MaryEra
witness'] TxBody MaryEra
txRaw
    SubmitResult (TxValidationErrorInMode CardanoMode)
result <- String
-> ConsensusModeParams CardanoMode
-> NetworkId
-> Tx MaryEra
-> MantisM m (SubmitResult (TxValidationErrorInMode CardanoMode))
forall (m :: * -> *).
MonadIO m =>
String
-> ConsensusModeParams CardanoMode
-> NetworkId
-> Tx MaryEra
-> MantisM m (SubmitResult (TxValidationErrorInMode CardanoMode))
submitTransaction String
socket ConsensusModeParams CardanoMode
protocol NetworkId
network Tx MaryEra
txSigned
    case SubmitResult (TxValidationErrorInMode CardanoMode)
result of
      SubmitResult (TxValidationErrorInMode CardanoMode)
SubmitSuccess     -> String -> MantisM m ()
forall (m :: * -> *). MonadIO m => String -> MantisM m ()
printMantis (String -> MantisM m ()) -> String -> MantisM m ()
forall a b. (a -> b) -> a -> b
$ String
"  Success: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxId -> String
forall a. Show a => a -> String
show (TxBody MaryEra -> TxId
forall era. TxBody era -> TxId
getTxId TxBody MaryEra
txRaw)
      SubmitFail TxValidationErrorInMode CardanoMode
reason -> String -> MantisM m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError  (String -> MantisM m ()) -> String -> MantisM m ()
forall a b. (a -> b) -> a -> b
$ String
"  Failure: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TxValidationErrorInMode CardanoMode -> String
forall a. Show a => a -> String
show TxValidationErrorInMode CardanoMode
reason