Command.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-orphans #-}

module Cardano.Benchmarking.Command
(
  runCommand
, commandParser -- for tests
)
where

#if !defined(mingw32_HOST_OS)
#define UNIX
#endif

import           Cardano.Benchmarking.Compiler (compileOptions)
import qualified Cardano.Benchmarking.LogTypes as LogTypes (EnvConsts (..))
import           Cardano.Benchmarking.Script (parseScriptFileAeson, runScript)
import           Cardano.Benchmarking.Script.Aeson (parseJSONFile, prettyPrint)
import           Cardano.Benchmarking.Script.Env as Env (emptyEnv, newEnvConsts)
import           Cardano.Benchmarking.Script.Selftest (runSelftest)
import           Cardano.Benchmarking.Version as Version
import           Cardano.TxGenerator.PlutusContext (readScriptData)
import           Cardano.TxGenerator.Setup.NixService
import           Cardano.TxGenerator.Types (TxGenPlutusParams (..))
import           Data.Aeson (fromJSON)
import           Data.ByteString.Lazy as BSL
import           Data.Foldable (for_)
import           Data.Maybe (catMaybes)
import qualified Data.Text.IO as Text
import           Options.Applicative as Opt
import           Cardano.Network.NodeToClient (IOManager, withIOManager)

import           System.Exit

import           Control.Concurrent (myThreadId)
import           Control.Concurrent as Weak (mkWeakThreadId)
import           Control.Concurrent.STM as STM (readTVar)
import           Control.Monad.STM as STM (atomically)

#ifdef UNIX
import           Cardano.Benchmarking.LogTypes (AsyncBenchmarkControl (..), BenchTracers (..),
                   TraceBenchTxSubmit (..))
import           Cardano.Logging as Tracer (traceWith)
import           Control.Concurrent.Async as Async (cancelWith)
import           Control.Concurrent as Conc (killThread)
import           GHC.Weak as Weak (deRefWeak)
import           Data.Foldable as Fold (forM_)
import           Data.List as List (unwords)
import qualified Data.Text as Text
import           Data.Time.Format as Time (defaultTimeLocale, formatTime)
import           Data.Time.Clock.System as Time (getSystemTime, systemToUTCTime)
import           Foreign.C (Errno(..))

import           System.Posix.Signals as Sig (Handler (CatchInfo),
                   SignalInfo (..), SignalSpecificInfo (..), installHandler,
                   sigINT, sigTERM)
#if MIN_VERSION_base(4,18,0)
import           Data.Maybe as Maybe (fromMaybe)
import           GHC.Conc.Sync as Conc (threadLabel)
#endif
#endif

#ifdef UNIX
deriving instance Show Errno
deriving instance Show SignalInfo
deriving instance Show SignalSpecificInfo
#endif

data Command
  = Json FilePath
  | JsonHL FilePath (Maybe FilePath) (Maybe FilePath)
  | Compile FilePath
  | Selftest (Maybe FilePath)
  | VersionCmd

runCommand :: IO ()
runCommand = withIOManager runCommand'

runCommand' :: IOManager -> IO ()
runCommand' iocp = do
  envConsts <- installSignalHandler
  cmd <- customExecParser
           (prefs showHelpOnEmpty)
           (info commandParser mempty)
  case cmd of
    Json actionFile -> do
      script <- parseScriptFileAeson actionFile
      runScript emptyEnv script envConsts >>= handleError . fst
    JsonHL nixSvcOptsFile nodeConfigOverwrite cardanoTracerOverwrite -> do
      opts <- parseJSONFile fromJSON nixSvcOptsFile
      finalOpts <- mangleTracerConfig cardanoTracerOverwrite <$> mangleNodeConfig nodeConfigOverwrite opts
      let consts = envConsts { LogTypes.envNixSvcOpts = Just finalOpts }

      Prelude.putStrLn $
          "--> initial options:\n" ++ show opts ++
        "\n--> final options:\n" ++ show finalOpts

      quickTestPlutusDataOrDie finalOpts

      case compileOptions finalOpts of
        Right script -> runScript emptyEnv script consts >>= handleError . fst
        err -> die $ "tx-generator:Cardano.Command.runCommand JsonHL: " ++ show err
    Compile file -> do
      o <- parseJSONFile fromJSON file
      case compileOptions o of
        Right script -> BSL.putStr $ prettyPrint script
        Left err -> die $ "tx-generator:Cardano.Command.runCommand Compile: " ++ show err
    Selftest outFile -> runSelftest emptyEnv envConsts outFile >>= handleError
    VersionCmd -> runVersionCommand
  where
  handleError :: Show a => Either a b -> IO ()
  handleError = \case
    Right _  -> exitSuccess
    Left err -> die $ "tx-generator:Cardano.Command.runCommand handleError: " ++ show err
  installSignalHandler :: IO LogTypes.EnvConsts
  installSignalHandler = do
    -- The main thread does not appear in the set of asyncs.
    wkMainTID <- Weak.mkWeakThreadId =<< myThreadId
    envConsts@LogTypes.EnvConsts { .. } <- STM.atomically $ newEnvConsts iocp Nothing
    abc <- STM.atomically $ STM.readTVar envThreads
    _ <- pure (abc, wkMainTID)
#ifdef UNIX
    let signalHandler = Sig.CatchInfo signalHandler'
        signalHandler' sigInfo = do
          tid <- myThreadId
          utcTime <- Time.systemToUTCTime <$> Time.getSystemTime
          -- It's meant to match Cardano.Tracers.Handlers.Logs.Utils
          -- The hope was to avoid the package dependency.
          let formatTimeStamp = formatTime' "%Y-%m-%dT%H-%M-%S"
              formatTime' = Time.formatTime Time.defaultTimeLocale
              timeStamp = formatTimeStamp utcTime
#if MIN_VERSION_base(4,18,0)
          maybeLabel <- Conc.threadLabel tid
          let labelStr' :: String
              labelStr' = fromMaybe "(thread label unset)" maybeLabel
#else
              labelStr' = "(base version insufficient to read thread label)"
#endif
              labelStr  :: String
              labelStr  = List.unwords [ timeStamp
                                       , labelStr'
                                       , show tid
                                       , "received signal"
                                       , show sigInfo ]
              errorToThrow :: IOError
              errorToThrow = userError labelStr
              tag = TraceBenchTxSubError . Text.pack
              traceWith' msg = do
                mBenchTracer <- STM.atomically do readTVar benchTracers
                case mBenchTracer of
                  Nothing -> pure ()
                  Just tracers -> do
                    let wrappedMsg = tag msg
                        submittedTracers = btTxSubmit_ tracers
                    Tracer.traceWith submittedTracers wrappedMsg

          Prelude.putStrLn labelStr
          traceWith' labelStr
          mABC <- STM.atomically $ STM.readTVar envThreads
          case mABC of
            Nothing -> do
              -- Catching a signal at this point makes it a higher than
              -- average risk of the tracer not being initialized, so
              -- this pursues some alternatives.
              let errMsg = "Signal received before AsyncBenchmarkControl creation."
              Prelude.putStrLn errMsg
              traceWith' errMsg
            Just AsyncBenchmarkControl { .. } -> do
              abcFeeder `Async.cancelWith` errorToThrow
              Fold.forM_ abcWorkers \work -> do
                work `Async.cancelWith` errorToThrow
              -- The main thread does __NOT__ appear in the above list.
              -- In order to kill that off, this, or some equivalent,
              -- absolutely /must/ be done separately.
          mapM_ Conc.killThread =<< Weak.deRefWeak wkMainTID
    Fold.forM_ [Sig.sigINT, Sig.sigTERM] $ \sig ->
           Sig.installHandler sig signalHandler Nothing
#endif
    pure envConsts

  mangleNodeConfig :: Maybe FilePath -> NixServiceOptions -> IO NixServiceOptions
  mangleNodeConfig fp opts = case (getNodeConfigFile opts, fp) of
    (_      , Just newFilePath) -> return $ setNodeConfigFile opts newFilePath
    (Just _ , Nothing) -> return opts
    (Nothing, Nothing) -> die "No node-configFile set"

  mangleTracerConfig ::  Maybe FilePath -> NixServiceOptions -> NixServiceOptions
  mangleTracerConfig traceSocket opts
    = opts { _nix_cardanoTracerSocket = traceSocket <> _nix_cardanoTracerSocket opts}

-- if there's a parsing error wrt. ScriptData, we want to fail early, before the splitting phase
quickTestPlutusDataOrDie :: NixServiceOptions -> IO ()
quickTestPlutusDataOrDie NixServiceOptions{_nix_plutus} = do
  for_ files test
  Prelude.putStrLn $
    "--> success: quickTestPlutusDataOrDie " ++ show files
  where
    test file =
      readScriptData file >>= \case
        Left err -> die $ "quickTestPlutusDataOrDie (" ++ file ++ "): " ++ show err
        Right{}  -> pure ()

    files = case _nix_plutus of
      Just PlutusOn{plutusDatum, plutusRedeemer}  -> catMaybes [plutusDatum, plutusRedeemer]
      _ -> []

commandParser :: Parser Command
commandParser
  = subparser (
       cmdParser "json" jsonCmd "Run a generic benchmarking script."
    <> cmdParser "json_highlevel" jsonHLCmd "Run the tx-generator using a flat config."
    <> cmdParser "compile" compileCmd "Compile flat-options to benchmarking script."
    <> cmdParser "selftest" selfTestCmd "Run a build-in selftest."
    <> cmdParser "version" versionCmd "Show the tx-generator version"
       )
 where
  cmdParser cmd parser description = command cmd $ info parser $ progDesc description

  filePath :: String -> Parser String
  filePath helpMsg = strArgument (metavar "FILEPATH" <> help helpMsg)

  jsonCmd :: Parser Command
  jsonCmd = Json <$> filePath "low-level benchmarking script"

  jsonHLCmd :: Parser Command
  jsonHLCmd = JsonHL <$> filePath "benchmarking options"
                     <*> nodeConfigOpt
                     <*> tracerConfigOpt
  compileCmd :: Parser Command
  compileCmd = Compile <$> filePath "benchmarking options"

  selfTestCmd = Selftest <$> optional (filePath "output file")

  nodeConfigOpt :: Parser (Maybe FilePath)
  nodeConfigOpt = option (Just <$> str)
    ( long "nodeConfig"
      <> short 'n'
      <> metavar "FILENAME"
      <> value Nothing
      <> help "the node configfile"
    )

  tracerConfigOpt :: Parser (Maybe FilePath)
  tracerConfigOpt = option (Just <$> str)
    ( long "cardano-tracer"
      <> short 'n'
      <> metavar "SOCKET"
      <> value Nothing
      <> help "the cardano-tracer socket"
    )

  versionCmd :: Parser Command
  versionCmd = pure VersionCmd

runVersionCommand :: IO ()
runVersionCommand = Text.putStrLn $ multilineVersionMsg txGeneratorVersion