{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-
Extract validators and partial transactions from emulator traces
-}
module Plutus.Trace.Emulator.Extract(
  ValidatorMode(..),
  writeScriptsTo,
  showStats,
  ScriptsConfig(..),
  Command(..)
) where

import Cardano.Api qualified as C
import Cardano.Node.Emulator.Internal.Node (CardanoLedgerError, Params (..), makeTransactionBody, networkIdL,
                                            protocolParamsL)
import Control.Foldl qualified as L
import Control.Lens ((&), (.~))
import Control.Monad.Freer (run)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable (traverse_)
import Data.Int (Int64)
import Data.Monoid (Sum (..))

import Ledger.Tx.CardanoAPI (fromPlutusIndex)
import Ledger.Tx.Constraints.OffChain (UnbalancedTx (..))
import Plutus.Contract.Request (MkTxLog)
import Plutus.Trace.Emulator (EmulatorConfig (_params), EmulatorTrace)
import Plutus.Trace.Emulator qualified as Trace
import Plutus.V1.Ledger.Api (ExBudget (..))
import Prettyprinter (Pretty (..))
import Streaming.Prelude qualified as S
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import Text.Printf (printf)
import Wallet.Emulator.Folds qualified as Folds
import Wallet.Emulator.Stream (foldEmulatorStreamM)

-- | Configuration for 'writeScriptsTo'
data ScriptsConfig =
    ScriptsConfig
        { ScriptsConfig -> FilePath
scPath    :: FilePath -- ^ Folder the extracted scripts should be written to
        , ScriptsConfig -> Command
scCommand :: Command -- ^ Whether to write out complete transactions or just the validator scripts
        }

data ValidatorMode = FullyAppliedValidators | UnappliedValidators
    deriving (ValidatorMode -> ValidatorMode -> Bool
(ValidatorMode -> ValidatorMode -> Bool)
-> (ValidatorMode -> ValidatorMode -> Bool) -> Eq ValidatorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidatorMode -> ValidatorMode -> Bool
$c/= :: ValidatorMode -> ValidatorMode -> Bool
== :: ValidatorMode -> ValidatorMode -> Bool
$c== :: ValidatorMode -> ValidatorMode -> Bool
Eq, Eq ValidatorMode
Eq ValidatorMode
-> (ValidatorMode -> ValidatorMode -> Ordering)
-> (ValidatorMode -> ValidatorMode -> Bool)
-> (ValidatorMode -> ValidatorMode -> Bool)
-> (ValidatorMode -> ValidatorMode -> Bool)
-> (ValidatorMode -> ValidatorMode -> Bool)
-> (ValidatorMode -> ValidatorMode -> ValidatorMode)
-> (ValidatorMode -> ValidatorMode -> ValidatorMode)
-> Ord ValidatorMode
ValidatorMode -> ValidatorMode -> Bool
ValidatorMode -> ValidatorMode -> Ordering
ValidatorMode -> ValidatorMode -> ValidatorMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidatorMode -> ValidatorMode -> ValidatorMode
$cmin :: ValidatorMode -> ValidatorMode -> ValidatorMode
max :: ValidatorMode -> ValidatorMode -> ValidatorMode
$cmax :: ValidatorMode -> ValidatorMode -> ValidatorMode
>= :: ValidatorMode -> ValidatorMode -> Bool
$c>= :: ValidatorMode -> ValidatorMode -> Bool
> :: ValidatorMode -> ValidatorMode -> Bool
$c> :: ValidatorMode -> ValidatorMode -> Bool
<= :: ValidatorMode -> ValidatorMode -> Bool
$c<= :: ValidatorMode -> ValidatorMode -> Bool
< :: ValidatorMode -> ValidatorMode -> Bool
$c< :: ValidatorMode -> ValidatorMode -> Bool
compare :: ValidatorMode -> ValidatorMode -> Ordering
$ccompare :: ValidatorMode -> ValidatorMode -> Ordering
$cp1Ord :: Eq ValidatorMode
Ord, Int -> ValidatorMode -> ShowS
[ValidatorMode] -> ShowS
ValidatorMode -> FilePath
(Int -> ValidatorMode -> ShowS)
-> (ValidatorMode -> FilePath)
-> ([ValidatorMode] -> ShowS)
-> Show ValidatorMode
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ValidatorMode] -> ShowS
$cshowList :: [ValidatorMode] -> ShowS
show :: ValidatorMode -> FilePath
$cshow :: ValidatorMode -> FilePath
showsPrec :: Int -> ValidatorMode -> ShowS
$cshowsPrec :: Int -> ValidatorMode -> ShowS
Show)

-- | Command for 'writeScriptsTo'
data Command =
    Scripts -- ^ Write out validator scripts only (flat encoding)
        { Command -> ValidatorMode
unappliedValidators :: ValidatorMode -- ^ Whether to write fully applied or unapplied validators
        }
    | Transactions  -- ^ Write out partial transactions
        { Command -> NetworkId
networkId          :: C.NetworkId -- ^ Network ID to use when creating addresses
        , Command -> FilePath
protocolParamsJSON :: FilePath -- ^ Location of a JSON file with protocol parameters
        }
    | MkTxLogs -- ^ Write out the arguments and results of 'mkTx' calls
    deriving stock (Int -> Command -> ShowS
[Command] -> ShowS
Command -> FilePath
(Int -> Command -> ShowS)
-> (Command -> FilePath) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> FilePath
$cshow :: Command -> FilePath
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq)

{-| Run an emulator trace and write the applied scripts to a file in Flat format
    using the name as a prefix.
-}
writeScriptsTo
    :: ScriptsConfig -- ^ Configuration
    -> String -- ^ Prefix to be used for file names
    -> EmulatorTrace a -- ^ Emulator trace to extract transactions from
    -> EmulatorConfig -- ^ Emulator config
    -> IO (Sum Int64, ExBudget) -- Total size and 'ExBudget' of extracted scripts
writeScriptsTo :: ScriptsConfig
-> FilePath
-> EmulatorTrace a
-> EmulatorConfig
-> IO (Sum Int64, ExBudget)
writeScriptsTo ScriptsConfig{FilePath
scPath :: FilePath
scPath :: ScriptsConfig -> FilePath
scPath, Command
scCommand :: Command
scCommand :: ScriptsConfig -> Command
scCommand} FilePath
prefix EmulatorTrace a
trace EmulatorConfig
emulatorCfg = do
    let stream :: Stream
  (Of (LogMessage EmulatorEvent))
  (Eff effs)
  (Either EmulatorErr a, EmulatorState)
stream = EmulatorConfig
-> EmulatorTrace a
-> Stream
     (Of (LogMessage EmulatorEvent))
     (Eff effs)
     (Either EmulatorErr a, EmulatorState)
forall (effs :: [* -> *]) a.
EmulatorConfig
-> EmulatorTrace a
-> Stream
     (Of (LogMessage EmulatorEvent))
     (Eff effs)
     (Either EmulatorErr a, EmulatorState)
Trace.runEmulatorStream EmulatorConfig
emulatorCfg EmulatorTrace a
trace
        getEvents :: Folds.EmulatorEventFold a -> a
        getEvents :: EmulatorEventFold a -> a
getEvents EmulatorEventFold a
theFold = Of a (Either EmulatorErr a, EmulatorState) -> a
forall a b. Of a b -> a
S.fst' (Of a (Either EmulatorErr a, EmulatorState) -> a)
-> Of a (Either EmulatorErr a, EmulatorState) -> a
forall a b. (a -> b) -> a -> b
$ Eff '[] (Of a (Either EmulatorErr a, EmulatorState))
-> Of a (Either EmulatorErr a, EmulatorState)
forall a. Eff '[] a -> a
run (Eff '[] (Of a (Either EmulatorErr a, EmulatorState))
 -> Of a (Either EmulatorErr a, EmulatorState))
-> Eff '[] (Of a (Either EmulatorErr a, EmulatorState))
-> Of a (Either EmulatorErr a, EmulatorState)
forall a b. (a -> b) -> a -> b
$ FoldM (Eff '[]) EmulatorEvent a
-> Stream
     (Of (LogMessage EmulatorEvent))
     (Eff '[])
     (Either EmulatorErr a, EmulatorState)
-> Eff '[] (Of a (Either EmulatorErr a, EmulatorState))
forall (effs :: [* -> *]) a b.
FoldM (Eff effs) EmulatorEvent b
-> Stream (Of (LogMessage EmulatorEvent)) (Eff effs) a
-> Eff effs (Of b a)
foldEmulatorStreamM (EmulatorEventFold a -> FoldM (Eff '[]) EmulatorEvent a
forall (m :: * -> *) a b. Monad m => Fold a b -> FoldM m a b
L.generalize EmulatorEventFold a
theFold) Stream
  (Of (LogMessage EmulatorEvent))
  (Eff '[])
  (Either EmulatorErr a, EmulatorState)
forall (effs :: [* -> *]).
Stream
  (Of (LogMessage EmulatorEvent))
  (Eff effs)
  (Either EmulatorErr a, EmulatorState)
stream
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
scPath
    case Command
scCommand of
        Scripts ValidatorMode
_ -> (Sum Int64, ExBudget) -> IO (Sum Int64, ExBudget)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sum Int64, ExBudget)
forall a. Monoid a => a
mempty
        Transactions{NetworkId
networkId :: NetworkId
networkId :: Command -> NetworkId
networkId, FilePath
protocolParamsJSON :: FilePath
protocolParamsJSON :: Command -> FilePath
protocolParamsJSON} -> do
            ByteString
bs <- FilePath -> IO ByteString
BSL.readFile FilePath
protocolParamsJSON
            case ByteString -> Either FilePath ProtocolParameters
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode ByteString
bs of
                Left FilePath
err -> FilePath -> IO ()
putStrLn FilePath
err
                Right ProtocolParameters
pp ->
                    let params :: Params
params = EmulatorConfig -> Params
_params EmulatorConfig
emulatorCfg Params -> (Params -> Params) -> Params
forall a b. a -> (a -> b) -> b
& (ProtocolParameters -> Identity ProtocolParameters)
-> Params -> Identity Params
Lens' Params ProtocolParameters
protocolParamsL ((ProtocolParameters -> Identity ProtocolParameters)
 -> Params -> Identity Params)
-> ProtocolParameters -> Params -> Params
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtocolParameters
pp
                                                     Params -> (Params -> Params) -> Params
forall a b. a -> (a -> b) -> b
& (NetworkId -> Identity NetworkId) -> Params -> Identity Params
Lens' Params NetworkId
networkIdL ((NetworkId -> Identity NetworkId) -> Params -> Identity Params)
-> NetworkId -> Params -> Params
forall s t a b. ASetter s t a b -> b -> s -> t
.~ NetworkId
networkId
                    in ((Int, UnbalancedTx) -> IO ()) -> [(Int, UnbalancedTx)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                        ((Int -> UnbalancedTx -> IO ()) -> (Int, UnbalancedTx) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> UnbalancedTx -> IO ()) -> (Int, UnbalancedTx) -> IO ())
-> (Int -> UnbalancedTx -> IO ()) -> (Int, UnbalancedTx) -> IO ()
forall a b. (a -> b) -> a -> b
$ Params -> FilePath -> FilePath -> Int -> UnbalancedTx -> IO ()
writeTransaction Params
params FilePath
scPath FilePath
prefix)
                        ([Int] -> [UnbalancedTx] -> [(Int, UnbalancedTx)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1::Int ..] ([UnbalancedTx] -> [(Int, UnbalancedTx)])
-> [UnbalancedTx] -> [(Int, UnbalancedTx)]
forall a b. (a -> b) -> a -> b
$ EmulatorEventFold [UnbalancedTx] -> [UnbalancedTx]
forall a. EmulatorEventFold a -> a
getEvents EmulatorEventFold [UnbalancedTx]
Folds.walletTxBalanceEvents)
            (Sum Int64, ExBudget) -> IO (Sum Int64, ExBudget)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sum Int64, ExBudget)
forall a. Monoid a => a
mempty
        Command
MkTxLogs -> do
            ((Int, MkTxLog) -> IO ()) -> [(Int, MkTxLog)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                ((Int -> MkTxLog -> IO ()) -> (Int, MkTxLog) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> MkTxLog -> IO ()) -> (Int, MkTxLog) -> IO ())
-> (Int -> MkTxLog -> IO ()) -> (Int, MkTxLog) -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Int -> MkTxLog -> IO ()
writeMkTxLog FilePath
scPath FilePath
prefix)
                ([Int] -> [MkTxLog] -> [(Int, MkTxLog)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1::Int ..] ([MkTxLog] -> [(Int, MkTxLog)]) -> [MkTxLog] -> [(Int, MkTxLog)]
forall a b. (a -> b) -> a -> b
$ EmulatorEventFold [MkTxLog] -> [MkTxLog]
forall a. EmulatorEventFold a -> a
getEvents EmulatorEventFold [MkTxLog]
Folds.mkTxLogs)
            (Sum Int64, ExBudget) -> IO (Sum Int64, ExBudget)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sum Int64, ExBudget)
forall a. Monoid a => a
mempty

showStats :: Int64 -> ExBudget -> String
showStats :: Int64 -> ExBudget -> FilePath
showStats Int64
byteSize (ExBudget ExCPU
exCPU ExMemory
exMemory) = FilePath
"Size: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
size FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"kB, Cost: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExCPU -> FilePath
forall a. Show a => a -> FilePath
show ExCPU
exCPU FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExMemory -> FilePath
forall a. Show a => a -> FilePath
show ExMemory
exMemory
    where
        size :: FilePath
size = FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf (FilePath
"%.1f"::String) (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
byteSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1024.0 :: Double)

writeTransaction
    :: Params
    -> FilePath
    -> String
    -> Int
    -> UnbalancedTx
    -> IO ()
writeTransaction :: Params -> FilePath -> FilePath -> Int -> UnbalancedTx -> IO ()
writeTransaction Params
params FilePath
fp FilePath
prefix Int
idx UnbalancedTx
utx = do
    let filename1 :: FilePath
filename1 = FilePath
fp FilePath -> ShowS
</> FilePath
prefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idx FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
".json"
    case UnbalancedTx -> Either CardanoLedgerError (Tx BabbageEra)
buildTx UnbalancedTx
utx of
        Left CardanoLedgerError
err ->
            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Export tx failed for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
filename1 FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
". Reason: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Doc Any -> FilePath
forall a. Show a => a -> FilePath
show (CardanoLedgerError -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty CardanoLedgerError
err)
        Right Tx BabbageEra
ctx -> do
            FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Writing partial transaction JSON: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
filename1
            FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
filename1 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Tx BabbageEra
ctx
    where
      buildTx :: UnbalancedTx -> Either CardanoLedgerError (C.Tx C.BabbageEra)
      buildTx :: UnbalancedTx -> Either CardanoLedgerError (Tx BabbageEra)
buildTx (UnbalancedCardanoTx CardanoBuildTx
tx UtxoIndex
utxos) =
        [KeyWitness BabbageEra] -> TxBody BabbageEra -> Tx BabbageEra
forall era. [KeyWitness era] -> TxBody era -> Tx era
C.makeSignedTransaction [] (TxBody BabbageEra -> Tx BabbageEra)
-> Either CardanoLedgerError (TxBody BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError (TxBody BabbageEra)
makeTransactionBody Params
params (UtxoIndex -> UTxO EmulatorEra
fromPlutusIndex UtxoIndex
utxos) CardanoBuildTx
tx


writeMkTxLog :: FilePath -> String -> Int -> MkTxLog -> IO ()
writeMkTxLog :: FilePath -> FilePath -> Int -> MkTxLog -> IO ()
writeMkTxLog FilePath
fp FilePath
prefix Int
idx MkTxLog
event = do
    let filename1 :: FilePath
filename1 = FilePath
fp FilePath -> ShowS
</> FilePath
prefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idx FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-mkTx.json"
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Writing mkTxLog transaction JSON: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
filename1
    FilePath -> ByteString -> IO ()
BSL.writeFile FilePath
filename1 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ MkTxLog -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty MkTxLog
event