Action.hs

{-# LANGUAGE GADTs #-}
{-|
Module      : Cardano.Benchmarking.Script.Action
Description : Convert an 'Action' to a monadic 'ActionM'.

This is just exporting 'action', and 'liftToAction' is tough
to use because of the risk of circular imports.
-}

module Cardano.Benchmarking.Script.Action
       ( action
       , liftToAction
       )
       where

import           Cardano.Benchmarking.OuroborosImports as Core (protocolToNetworkId)
import           Cardano.Benchmarking.Script.Core
import           Cardano.Benchmarking.Script.Env
import           Cardano.Benchmarking.Script.Types
import           Cardano.Benchmarking.Tracer
import           Cardano.TxGenerator.Setup.NodeConfig
import           Cardano.TxGenerator.Types (TxGenError)

import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except.Extra
import qualified Data.Text as Text (unpack)


-- | 'action' has as its sole callers
-- 'Cardano.Benchmark.Script.runScript' from "Cardano.Benchmark.Script"
-- and 'Cardano.Benchmark.Script.Selftest' from
-- "Cardano.Benchmark.Script.Selftest".
-- It translates the various cases of the 'Action' to monadic values
-- which execute the specified actions when evaluated. It passes all
-- the cases' fields to functions with very similar names to the
-- constructors.
action :: Action -> ActionM ()
action a = case a of
  SetNetworkId val -> setEnvNetworkId val
  SetSocketPath val -> setEnvSocketPath val
  InitWallet name -> initWallet name
  SetProtocolParameters p -> setProtocolParameters p
  StartProtocol configFile cardanoTracerSocket -> startProtocol configFile cardanoTracerSocket
  ReadSigningKey name filePath -> readSigningKey name filePath
  DefineSigningKey name descr -> defineSigningKey name descr
  AddFund era wallet txIn lovelace keyName -> addFund era wallet txIn lovelace keyName
  Delay t -> delay t
  Submit era submitMode txParams generator -> submitAction era submitMode generator txParams
  WaitBenchmark -> waitBenchmark
  CancelBenchmark -> cancelBenchmark
  WaitForEra era -> waitForEra era
  LogMsg txt -> traceDebug $ Text.unpack txt
  Reserved options -> reserved options

-- | 'liftToAction' first lifts from IO, then converts an 'Either'
-- to an 'Control.Monad.Trans.Except.ExceptT' and then transforms
-- the error type to 'Cardano.Benchmarking.Script.Env.Error'.
liftToAction :: IO (Either TxGenError a) -> ActionM a
liftToAction = firstExceptT TxGenError . newExceptT . liftIO

-- | 'startProtocol' sets up the protocol for the transaction
-- generator from the first argument, @configFile@ and optionally
-- traces to the second, @tracerSocket@.
startProtocol :: FilePath -> Maybe FilePath -> ActionM ()
startProtocol configFile tracerSocket = do
  nodeConfig <- liftToAction $ mkNodeConfig configFile
  protocol <-  liftToAction $ mkConsensusProtocol nodeConfig
  setEnvProtocol protocol
  setEnvGenesis $ getGenesis protocol
  iomgr <- askIOManager

  networkId <- liftIO $ protocolToNetworkId protocol
  let
    tracerSocket' = (,,) iomgr networkId `fmap` tracerSocket

  setEnvNetworkId networkId
  liftIO (initTxGenTracers tracerSocket') >>= setBenchTracers