{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

module Cardano.ChainIndex.Types where

import Control.Lens (makeLenses)
import Control.Monad.Freer.State
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (Default, def)
import GHC.Generics (Generic)
import Prettyprinter (Pretty (..), parens, (<+>))
import Servant.Client (BaseUrl (..), Scheme (..))

import Cardano.BM.Data.Trace (Trace)
import Cardano.BM.Data.Tracer (ToObject (..))
import Cardano.BM.Data.Tracer.Extras (Tagged (..), mkObjectStr)
import Control.Monad.Freer.Error (Error)
import Control.Monad.Freer.Extras (LogMsg)
import Plutus.ChainIndex.Emulator (ChainIndexControlEffect, ChainIndexEmulatorState, ChainIndexError, ChainIndexLog,
                                   ChainIndexQueryEffect)

type ChainIndexEffects m
     = '[ ChainIndexControlEffect
        , ChainIndexQueryEffect
        , State ChainIndexEmulatorState
        , LogMsg ChainIndexLog
        , Error ChainIndexError
        , m
        ]

newtype ChainIndexUrl = ChainIndexUrl BaseUrl
    deriving (ChainIndexUrl -> ChainIndexUrl -> Bool
(ChainIndexUrl -> ChainIndexUrl -> Bool)
-> (ChainIndexUrl -> ChainIndexUrl -> Bool) -> Eq ChainIndexUrl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainIndexUrl -> ChainIndexUrl -> Bool
$c/= :: ChainIndexUrl -> ChainIndexUrl -> Bool
== :: ChainIndexUrl -> ChainIndexUrl -> Bool
$c== :: ChainIndexUrl -> ChainIndexUrl -> Bool
Eq, Int -> ChainIndexUrl -> ShowS
[ChainIndexUrl] -> ShowS
ChainIndexUrl -> String
(Int -> ChainIndexUrl -> ShowS)
-> (ChainIndexUrl -> String)
-> ([ChainIndexUrl] -> ShowS)
-> Show ChainIndexUrl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainIndexUrl] -> ShowS
$cshowList :: [ChainIndexUrl] -> ShowS
show :: ChainIndexUrl -> String
$cshow :: ChainIndexUrl -> String
showsPrec :: Int -> ChainIndexUrl -> ShowS
$cshowsPrec :: Int -> ChainIndexUrl -> ShowS
Show, Value -> Parser [ChainIndexUrl]
Value -> Parser ChainIndexUrl
(Value -> Parser ChainIndexUrl)
-> (Value -> Parser [ChainIndexUrl]) -> FromJSON ChainIndexUrl
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChainIndexUrl]
$cparseJSONList :: Value -> Parser [ChainIndexUrl]
parseJSON :: Value -> Parser ChainIndexUrl
$cparseJSON :: Value -> Parser ChainIndexUrl
FromJSON, [ChainIndexUrl] -> Value
[ChainIndexUrl] -> Encoding
ChainIndexUrl -> Value
ChainIndexUrl -> Encoding
(ChainIndexUrl -> Value)
-> (ChainIndexUrl -> Encoding)
-> ([ChainIndexUrl] -> Value)
-> ([ChainIndexUrl] -> Encoding)
-> ToJSON ChainIndexUrl
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChainIndexUrl] -> Encoding
$ctoEncodingList :: [ChainIndexUrl] -> Encoding
toJSONList :: [ChainIndexUrl] -> Value
$ctoJSONList :: [ChainIndexUrl] -> Value
toEncoding :: ChainIndexUrl -> Encoding
$ctoEncoding :: ChainIndexUrl -> Encoding
toJSON :: ChainIndexUrl -> Value
$ctoJSON :: ChainIndexUrl -> Value
ToJSON) via BaseUrl

newtype ChainIndexConfig =
    ChainIndexConfig
        { ChainIndexConfig -> ChainIndexUrl
ciBaseUrl          :: ChainIndexUrl
        }
    deriving stock (Int -> ChainIndexConfig -> ShowS
[ChainIndexConfig] -> ShowS
ChainIndexConfig -> String
(Int -> ChainIndexConfig -> ShowS)
-> (ChainIndexConfig -> String)
-> ([ChainIndexConfig] -> ShowS)
-> Show ChainIndexConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainIndexConfig] -> ShowS
$cshowList :: [ChainIndexConfig] -> ShowS
show :: ChainIndexConfig -> String
$cshow :: ChainIndexConfig -> String
showsPrec :: Int -> ChainIndexConfig -> ShowS
$cshowsPrec :: Int -> ChainIndexConfig -> ShowS
Show, ChainIndexConfig -> ChainIndexConfig -> Bool
(ChainIndexConfig -> ChainIndexConfig -> Bool)
-> (ChainIndexConfig -> ChainIndexConfig -> Bool)
-> Eq ChainIndexConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainIndexConfig -> ChainIndexConfig -> Bool
$c/= :: ChainIndexConfig -> ChainIndexConfig -> Bool
== :: ChainIndexConfig -> ChainIndexConfig -> Bool
$c== :: ChainIndexConfig -> ChainIndexConfig -> Bool
Eq, (forall x. ChainIndexConfig -> Rep ChainIndexConfig x)
-> (forall x. Rep ChainIndexConfig x -> ChainIndexConfig)
-> Generic ChainIndexConfig
forall x. Rep ChainIndexConfig x -> ChainIndexConfig
forall x. ChainIndexConfig -> Rep ChainIndexConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainIndexConfig x -> ChainIndexConfig
$cfrom :: forall x. ChainIndexConfig -> Rep ChainIndexConfig x
Generic)
    deriving anyclass (Value -> Parser [ChainIndexConfig]
Value -> Parser ChainIndexConfig
(Value -> Parser ChainIndexConfig)
-> (Value -> Parser [ChainIndexConfig])
-> FromJSON ChainIndexConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChainIndexConfig]
$cparseJSONList :: Value -> Parser [ChainIndexConfig]
parseJSON :: Value -> Parser ChainIndexConfig
$cparseJSON :: Value -> Parser ChainIndexConfig
FromJSON, [ChainIndexConfig] -> Value
[ChainIndexConfig] -> Encoding
ChainIndexConfig -> Value
ChainIndexConfig -> Encoding
(ChainIndexConfig -> Value)
-> (ChainIndexConfig -> Encoding)
-> ([ChainIndexConfig] -> Value)
-> ([ChainIndexConfig] -> Encoding)
-> ToJSON ChainIndexConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChainIndexConfig] -> Encoding
$ctoEncodingList :: [ChainIndexConfig] -> Encoding
toJSONList :: [ChainIndexConfig] -> Value
$ctoJSONList :: [ChainIndexConfig] -> Value
toEncoding :: ChainIndexConfig -> Encoding
$ctoEncoding :: ChainIndexConfig -> Encoding
toJSON :: ChainIndexConfig -> Value
$ctoJSON :: ChainIndexConfig -> Value
ToJSON)

defaultChainIndexConfig :: ChainIndexConfig
defaultChainIndexConfig :: ChainIndexConfig
defaultChainIndexConfig =
  ChainIndexConfig :: ChainIndexUrl -> ChainIndexConfig
ChainIndexConfig
    -- See Note [pab-ports] in "test/full/Plutus/PAB/CliSpec.hs".
    { ciBaseUrl :: ChainIndexUrl
ciBaseUrl = BaseUrl -> ChainIndexUrl
ChainIndexUrl (BaseUrl -> ChainIndexUrl) -> BaseUrl -> ChainIndexUrl
forall a b. (a -> b) -> a -> b
$ Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" Int
9083 String
""
    }

instance Default ChainIndexConfig where
  def :: ChainIndexConfig
def = ChainIndexConfig
defaultChainIndexConfig

makeLenses ''ChainIndexConfig

-- | Messages from the ChainIndex Server
data ChainIndexServerMsg =
    -- | Starting a node client thread
      StartingNodeClientThread
    -- | Starting ChainIndex service
    | StartingChainIndex
        Int    -- ^ Port number
      -- | Received transaction
    | ReceivedBlocksTxns
        Int    -- ^ Blocks
        Int    -- ^ Transactions
    | ChainEvent ChainIndexLog
    deriving stock (Int -> ChainIndexServerMsg -> ShowS
[ChainIndexServerMsg] -> ShowS
ChainIndexServerMsg -> String
(Int -> ChainIndexServerMsg -> ShowS)
-> (ChainIndexServerMsg -> String)
-> ([ChainIndexServerMsg] -> ShowS)
-> Show ChainIndexServerMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainIndexServerMsg] -> ShowS
$cshowList :: [ChainIndexServerMsg] -> ShowS
show :: ChainIndexServerMsg -> String
$cshow :: ChainIndexServerMsg -> String
showsPrec :: Int -> ChainIndexServerMsg -> ShowS
$cshowsPrec :: Int -> ChainIndexServerMsg -> ShowS
Show, (forall x. ChainIndexServerMsg -> Rep ChainIndexServerMsg x)
-> (forall x. Rep ChainIndexServerMsg x -> ChainIndexServerMsg)
-> Generic ChainIndexServerMsg
forall x. Rep ChainIndexServerMsg x -> ChainIndexServerMsg
forall x. ChainIndexServerMsg -> Rep ChainIndexServerMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainIndexServerMsg x -> ChainIndexServerMsg
$cfrom :: forall x. ChainIndexServerMsg -> Rep ChainIndexServerMsg x
Generic)
    deriving anyclass ([ChainIndexServerMsg] -> Value
[ChainIndexServerMsg] -> Encoding
ChainIndexServerMsg -> Value
ChainIndexServerMsg -> Encoding
(ChainIndexServerMsg -> Value)
-> (ChainIndexServerMsg -> Encoding)
-> ([ChainIndexServerMsg] -> Value)
-> ([ChainIndexServerMsg] -> Encoding)
-> ToJSON ChainIndexServerMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ChainIndexServerMsg] -> Encoding
$ctoEncodingList :: [ChainIndexServerMsg] -> Encoding
toJSONList :: [ChainIndexServerMsg] -> Value
$ctoJSONList :: [ChainIndexServerMsg] -> Value
toEncoding :: ChainIndexServerMsg -> Encoding
$ctoEncoding :: ChainIndexServerMsg -> Encoding
toJSON :: ChainIndexServerMsg -> Value
$ctoJSON :: ChainIndexServerMsg -> Value
ToJSON, Value -> Parser [ChainIndexServerMsg]
Value -> Parser ChainIndexServerMsg
(Value -> Parser ChainIndexServerMsg)
-> (Value -> Parser [ChainIndexServerMsg])
-> FromJSON ChainIndexServerMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ChainIndexServerMsg]
$cparseJSONList :: Value -> Parser [ChainIndexServerMsg]
parseJSON :: Value -> Parser ChainIndexServerMsg
$cparseJSON :: Value -> Parser ChainIndexServerMsg
FromJSON)

type ChainIndexTrace = Trace IO ChainIndexServerMsg

instance Pretty ChainIndexServerMsg where
    pretty :: ChainIndexServerMsg -> Doc ann
pretty = \case
        ReceivedBlocksTxns Int
blocks Int
txns -> Doc ann
"Received" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
blocks Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"blocks" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
txns Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"transactions")
        ChainIndexServerMsg
StartingNodeClientThread -> Doc ann
"Starting node client thread"
        StartingChainIndex Int
port -> Doc ann
"Starting chain index on port" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
port
        ChainEvent ChainIndexLog
e -> Doc ann
"Processing chain index event:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ChainIndexLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ChainIndexLog
e

instance ToObject ChainIndexServerMsg where
    toObject :: TracingVerbosity -> ChainIndexServerMsg -> Object
toObject TracingVerbosity
_ = \case
      ReceivedBlocksTxns Int
x Int
y   -> Text -> (Tagged "blocks" Int, Tagged "transactions" Int) -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"received block transactions" (Int -> Tagged "blocks" Int
forall k (s :: k) b. b -> Tagged s b
Tagged @"blocks" Int
x, Int -> Tagged "transactions" Int
forall k (s :: k) b. b -> Tagged s b
Tagged @"transactions" Int
y)
      ChainIndexServerMsg
StartingNodeClientThread -> Text -> () -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"starting node client thread" ()
      StartingChainIndex Int
p     -> Text -> Tagged "port" Int -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"starting chain index" (Int -> Tagged "port" Int
forall k (s :: k) b. b -> Tagged s b
Tagged @"port" Int
p)
      ChainEvent ChainIndexLog
e             -> Text -> Tagged "event" ChainIndexLog -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"processing chain event" (ChainIndexLog -> Tagged "event" ChainIndexLog
forall k (s :: k) b. b -> Tagged s b
Tagged @"event" ChainIndexLog
e)