{-# LANGUAGE ApplicativeDo         #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}

module Plutus.PAB.Run
( runWith
, runWithOpts
) where

import Cardano.BM.Backend.EKGView qualified as EKGView
import Cardano.BM.Configuration.Model qualified as CM
import Cardano.BM.Data.Trace (Trace)
import Cardano.BM.Plugin (loadPlugin)
import Cardano.BM.Setup (setupTrace_)
import Cardano.Node.Types (pscPassphrase)
import Control.Applicative (Alternative ((<|>)))
import Control.Concurrent.Availability (newToken)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logErrorN, runStdoutLoggingT)
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (for_)
import Data.OpenApi.Schema qualified as OpenApi
import Data.Text.Extras (tshow)
import Data.Yaml (decodeFileThrow)
import Plutus.Monitoring.Util (PrettyObject (PrettyObject), convertLog)
import Plutus.PAB.Effects.Contract.Builtin (Builtin, BuiltinHandler, HasDefinitions)
import Plutus.PAB.Monitoring.Config (defaultConfig, loadConfig)
import Plutus.PAB.Monitoring.PABLogMsg (AppMsg)
import Plutus.PAB.Run.Cli (ConfigCommandArgs (ConfigCommandArgs), ccaAvailability, ccaLoggingConfig, ccaPABConfig,
                           ccaStorageBackend, ccaTrace, runConfigCommand)
import Plutus.PAB.Run.CommandParser
import Plutus.PAB.Types (Config (Config), DevelopmentOptions (pabResumeFrom, pabRollbackHistory),
                         PABError (MissingConfigFileOption), developmentOptions, nodeServerConfig)
import Prettyprinter (Pretty (pretty))
import Servant qualified
import System.Exit (ExitCode (ExitFailure), exitWith)

-- | PAB entry point for a contract type `a`.
runWith :: forall a.
    ( Show a
    , Ord a
    , FromJSON a
    , ToJSON a
    , Pretty a
    , Servant.MimeUnrender Servant.JSON a
    , HasDefinitions a
    , OpenApi.ToSchema a
    )
    => BuiltinHandler a -- ^ Builtin contract handler. Can be created with 'Plutus.PAB.Effects.Contract.Builtin.handleBuiltin'.
    -> IO ()
runWith :: BuiltinHandler a -> IO ()
runWith BuiltinHandler a
h = IO AppOpts
parseOptions IO AppOpts -> (AppOpts -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuiltinHandler a -> Maybe Config -> AppOpts -> IO ()
forall a.
(Show a, Ord a, FromJSON a, ToJSON a, Pretty a,
 MimeUnrender JSON a, HasDefinitions a, ToSchema a) =>
BuiltinHandler a -> Maybe Config -> AppOpts -> IO ()
runWithOpts BuiltinHandler a
h Maybe Config
forall a. Maybe a
Nothing

-- | Helper function to launch a complete PAB (all the necessary services)
-- that can be interacted over the API endpoints defined in
-- 'PAB.Webserver.Server'.
runWithOpts :: forall a.
    ( Show a
    , Ord a
    , FromJSON a
    , ToJSON a
    , Pretty a
    , Servant.MimeUnrender Servant.JSON a
    , HasDefinitions a
    , OpenApi.ToSchema a
    )
    => BuiltinHandler a
    -> Maybe Config -- ^ Optional config override to use in preference to the one in AppOpts
    -> AppOpts
    -> IO ()
runWithOpts :: BuiltinHandler a -> Maybe Config -> AppOpts -> IO ()
runWithOpts BuiltinHandler a
userContractHandler Maybe Config
mc AppOpts { Maybe Severity
minLogLevel :: AppOpts -> Maybe Severity
minLogLevel :: Maybe Severity
minLogLevel, Maybe Int
rollbackHistory :: AppOpts -> Maybe Int
rollbackHistory :: Maybe Int
rollbackHistory, Point
resumeFrom :: AppOpts -> Point
resumeFrom :: Point
resumeFrom, Maybe FilePath
logConfigPath :: AppOpts -> Maybe FilePath
logConfigPath :: Maybe FilePath
logConfigPath, Maybe Text
passphrase :: AppOpts -> Maybe Text
passphrase :: Maybe Text
passphrase, Bool
runEkgServer :: AppOpts -> Bool
runEkgServer :: Bool
runEkgServer, ConfigCommand
cmd :: AppOpts -> ConfigCommand
cmd :: ConfigCommand
cmd, Maybe FilePath
configPath :: AppOpts -> Maybe FilePath
configPath :: Maybe FilePath
configPath, StorageBackend
storageBackend :: AppOpts -> StorageBackend
storageBackend :: StorageBackend
storageBackend } = do
    -- Parse config files and initialize logging
    Configuration
logConfig <- IO Configuration
-> (FilePath -> IO Configuration)
-> Maybe FilePath
-> IO Configuration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Configuration
defaultConfig FilePath -> IO Configuration
loadConfig Maybe FilePath
logConfigPath
    Maybe Severity -> (Severity -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Severity
minLogLevel ((Severity -> IO ()) -> IO ()) -> (Severity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Severity
ll -> Configuration -> Severity -> IO ()
CM.setMinSeverity Configuration
logConfig Severity
ll
    (Trace IO (PrettyObject (AppMsg (Builtin a)))
trace :: Trace IO (PrettyObject (AppMsg (Builtin a))), Switchboard (PrettyObject (AppMsg (Builtin a)))
switchboard) <- Configuration
-> Text
-> IO
     (Trace IO (PrettyObject (AppMsg (Builtin a))),
      Switchboard (PrettyObject (AppMsg (Builtin a))))
forall (m :: * -> *) a.
(MonadIO m, ToJSON a, FromJSON a, ToObject a) =>
Configuration -> Text -> m (Trace m a, Switchboard a)
setupTrace_ Configuration
logConfig Text
"pab"

    -- enable EKG backend
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
runEkgServer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Configuration
-> Trace IO (PrettyObject (AppMsg (Builtin a)))
-> Switchboard (PrettyObject (AppMsg (Builtin a)))
-> IO (Plugin (PrettyObject (AppMsg (Builtin a))))
forall (s :: * -> *) a.
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration -> Trace IO a -> s a -> IO (Plugin a)
EKGView.plugin Configuration
logConfig Trace IO (PrettyObject (AppMsg (Builtin a)))
trace Switchboard (PrettyObject (AppMsg (Builtin a)))
switchboard IO (Plugin (PrettyObject (AppMsg (Builtin a))))
-> (Plugin (PrettyObject (AppMsg (Builtin a))) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard (PrettyObject (AppMsg (Builtin a)))
-> Plugin (PrettyObject (AppMsg (Builtin a))) -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard (PrettyObject (AppMsg (Builtin a)))
switchboard

    -- obtain token for signaling service readiness
    Availability
serviceAvailability <- IO Availability
forall (m :: * -> *). MonadIO m => m Availability
newToken

    Either PABError Config
pabConfig :: Either PABError Config <- case Maybe Config
mc of
        Just Config
config -> Either PABError Config -> IO (Either PABError Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PABError Config -> IO (Either PABError Config))
-> Either PABError Config -> IO (Either PABError Config)
forall a b. (a -> b) -> a -> b
$ Config -> Either PABError Config
forall a b. b -> Either a b
Right Config
config
        Maybe Config
Nothing ->
          case Maybe FilePath
configPath of
            Maybe FilePath
Nothing -> Either PABError Config -> IO (Either PABError Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PABError Config -> IO (Either PABError Config))
-> Either PABError Config -> IO (Either PABError Config)
forall a b. (a -> b) -> a -> b
$ PABError -> Either PABError Config
forall a b. a -> Either a b
Left PABError
MissingConfigFileOption
            Just FilePath
p  -> do Config -> Either PABError Config
forall a b. b -> Either a b
Right (Config -> Either PABError Config)
-> IO Config -> IO (Either PABError Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Config -> IO Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> IO Config) -> IO Config -> IO Config
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Config
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
decodeFileThrow FilePath
p)

    let mkNodeServerConfig :: PABServerConfig -> PABServerConfig
mkNodeServerConfig PABServerConfig
nodeServerConfig =
            PABServerConfig
nodeServerConfig
                { pscPassphrase :: Maybe Text
pscPassphrase = Maybe Text
passphrase Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PABServerConfig -> Maybe Text
pscPassphrase PABServerConfig
nodeServerConfig
                }
        mkDevOpts :: DevelopmentOptions -> DevelopmentOptions
mkDevOpts DevelopmentOptions
developmentOptions =
            DevelopmentOptions
developmentOptions
                { pabRollbackHistory :: Maybe Int
pabRollbackHistory = Maybe Int
rollbackHistory
                                   Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DevelopmentOptions -> Maybe Int
pabRollbackHistory DevelopmentOptions
developmentOptions
                , pabResumeFrom :: Point
pabResumeFrom = Point -> Point -> Point
forall a. Ord a => a -> a -> a
max Point
resumeFrom (DevelopmentOptions -> Point
pabResumeFrom DevelopmentOptions
developmentOptions)

                }
        mkArgs :: Config -> ConfigCommandArgs a
mkArgs config :: Config
config@Config{PABServerConfig
nodeServerConfig :: PABServerConfig
nodeServerConfig :: Config -> PABServerConfig
nodeServerConfig, DevelopmentOptions
developmentOptions :: DevelopmentOptions
developmentOptions :: Config -> DevelopmentOptions
developmentOptions} =
            ConfigCommandArgs :: forall a.
Trace IO (AppMsg (Builtin a))
-> Configuration
-> Config
-> Availability
-> StorageBackend
-> ConfigCommandArgs a
ConfigCommandArgs
                { ccaTrace :: Trace IO (AppMsg (Builtin a))
ccaTrace = (AppMsg (Builtin a) -> PrettyObject (AppMsg (Builtin a)))
-> Trace IO (PrettyObject (AppMsg (Builtin a)))
-> Trace IO (AppMsg (Builtin a))
forall a b (m :: * -> *). (a -> b) -> Trace m b -> Trace m a
convertLog AppMsg (Builtin a) -> PrettyObject (AppMsg (Builtin a))
forall t. t -> PrettyObject t
PrettyObject Trace IO (PrettyObject (AppMsg (Builtin a)))
trace
                , ccaLoggingConfig :: Configuration
ccaLoggingConfig = Configuration
logConfig
                , ccaPABConfig :: Config
ccaPABConfig =
                    Config
config { nodeServerConfig :: PABServerConfig
nodeServerConfig = PABServerConfig -> PABServerConfig
mkNodeServerConfig PABServerConfig
nodeServerConfig
                           , developmentOptions :: DevelopmentOptions
developmentOptions = DevelopmentOptions -> DevelopmentOptions
mkDevOpts DevelopmentOptions
developmentOptions
                           }
                , ccaAvailability :: Availability
ccaAvailability = Availability
serviceAvailability
                , ccaStorageBackend :: StorageBackend
ccaStorageBackend = StorageBackend
storageBackend
                }

    -- execute parsed pab command and handle errors on faliure
    Either PABError ()
result <- Either PABError (IO ()) -> IO (Either PABError ())
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (ConfigCommandArgs a -> IO ()
run (ConfigCommandArgs a -> IO ())
-> (Config -> ConfigCommandArgs a) -> Config -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> ConfigCommandArgs a
mkArgs (Config -> IO ())
-> Either PABError Config -> Either PABError (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either PABError Config
pabConfig)
    (PABError -> IO ()) -> (() -> IO ()) -> Either PABError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PABError -> IO ()
forall b. PABError -> IO b
handleError (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either PABError ()
result

    where
        run :: ConfigCommandArgs a -> IO ()
run ConfigCommandArgs a
config = BuiltinHandler a -> ConfigCommandArgs a -> ConfigCommand -> IO ()
forall a.
(Ord a, Show a, ToJSON a, FromJSON a, Pretty a,
 MimeUnrender JSON a, HasDefinitions a, ToSchema a) =>
BuiltinHandler a -> ConfigCommandArgs a -> ConfigCommand -> IO ()
runConfigCommand BuiltinHandler a
userContractHandler ConfigCommandArgs a
config ConfigCommand
cmd
        handleError :: PABError -> IO b
handleError (PABError
err :: PABError) = do
            LoggingT IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStdoutLoggingT (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> LoggingT IO ())
-> (PABError -> Text) -> PABError -> LoggingT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> Text
forall a. Show a => a -> Text
tshow (Doc Any -> Text) -> (PABError -> Doc Any) -> PABError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PABError -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty) PABError
err
            ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)