{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE KindSignatures    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}

module Cardano.Wallet.Mock.Types (
     -- * effect type for the mock wallet
      WalletEffects
    , Wallets
    , MultiWalletEffect (..)
    , createWallet
    , multiWallet
    , getWalletInfo

     -- * wallet log messages
    , WalletMsg (..)

     -- * newtypes for convenience
    , Port (..)
    , NodeClient (..)
    , ChainClient (..)
    , ChainIndexUrl
    -- * Wallet info
    , WalletInfo(..)
    , fromWalletState
    ) where

import Cardano.BM.Data.Tracer (ToObject (toObject))
import Cardano.BM.Data.Tracer.Extras (Tagged (Tagged), mkObjectStr)
import Cardano.ChainIndex.Types (ChainIndexUrl)
import Control.Monad.Freer (Eff)
import Control.Monad.Freer.Error (Error)
import Control.Monad.Freer.Extras.Log (LogMsg)
import Control.Monad.Freer.State (State)
import Control.Monad.Freer.TH (makeEffect)
import Data.Aeson (FromJSON, ToJSON)
import Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import Data.Text (Text)
import GHC.Generics (Generic)
import Ledger (CardanoAddress, PaymentPubKeyHash)
import Plutus.ChainIndex (ChainIndexQueryEffect)
import Plutus.PAB.Arbitrary ()
import Plutus.PAB.Types (PABError)
import Plutus.Script.Utils.Ada (Ada)
import Prettyprinter (Pretty (pretty), (<+>))
import Servant (ServerError)
import Servant.Client (ClientError)
import Servant.Client.Internal.HttpClient (ClientEnv)
import Wallet.Effects (NodeClientEffect, WalletEffect)
import Wallet.Emulator.Error (WalletAPIError)
import Wallet.Emulator.LogMessages (RequestHandlerLogMsg, TxBalanceMsg)
import Wallet.Emulator.Wallet (Wallet, WalletId, WalletState (WalletState, _mockWallet), mockWalletAddress,
                               mockWalletPaymentPubKeyHash, toMockWallet)

-- | Information about an emulated wallet.
data WalletInfo =
    WalletInfo
        { WalletInfo -> Wallet
wiWallet            :: Wallet
        , WalletInfo -> PaymentPubKeyHash
wiPaymentPubKeyHash :: PaymentPubKeyHash
        -- ^ Hash of the wallet's public key, serving as wallet ID.
        -- TODO Remove eventually as it is replaced by 'wiAddresses'.
        , WalletInfo -> NonEmpty CardanoAddress
wiAddresses         :: NonEmpty CardanoAddress -- ^ Wallet's addresses
        }
    deriving stock (Int -> WalletInfo -> ShowS
[WalletInfo] -> ShowS
WalletInfo -> String
(Int -> WalletInfo -> ShowS)
-> (WalletInfo -> String)
-> ([WalletInfo] -> ShowS)
-> Show WalletInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WalletInfo] -> ShowS
$cshowList :: [WalletInfo] -> ShowS
show :: WalletInfo -> String
$cshow :: WalletInfo -> String
showsPrec :: Int -> WalletInfo -> ShowS
$cshowsPrec :: Int -> WalletInfo -> ShowS
Show, (forall x. WalletInfo -> Rep WalletInfo x)
-> (forall x. Rep WalletInfo x -> WalletInfo) -> Generic WalletInfo
forall x. Rep WalletInfo x -> WalletInfo
forall x. WalletInfo -> Rep WalletInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WalletInfo x -> WalletInfo
$cfrom :: forall x. WalletInfo -> Rep WalletInfo x
Generic)
    deriving anyclass ([WalletInfo] -> Encoding
[WalletInfo] -> Value
WalletInfo -> Encoding
WalletInfo -> Value
(WalletInfo -> Value)
-> (WalletInfo -> Encoding)
-> ([WalletInfo] -> Value)
-> ([WalletInfo] -> Encoding)
-> ToJSON WalletInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [WalletInfo] -> Encoding
$ctoEncodingList :: [WalletInfo] -> Encoding
toJSONList :: [WalletInfo] -> Value
$ctoJSONList :: [WalletInfo] -> Value
toEncoding :: WalletInfo -> Encoding
$ctoEncoding :: WalletInfo -> Encoding
toJSON :: WalletInfo -> Value
$ctoJSON :: WalletInfo -> Value
ToJSON, Value -> Parser [WalletInfo]
Value -> Parser WalletInfo
(Value -> Parser WalletInfo)
-> (Value -> Parser [WalletInfo]) -> FromJSON WalletInfo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [WalletInfo]
$cparseJSONList :: Value -> Parser [WalletInfo]
parseJSON :: Value -> Parser WalletInfo
$cparseJSON :: Value -> Parser WalletInfo
FromJSON)

type Wallets = Map WalletId WalletState

fromWalletState :: WalletState -> WalletInfo
fromWalletState :: WalletState -> WalletInfo
fromWalletState WalletState{MockWallet
_mockWallet :: MockWallet
_mockWallet :: WalletState -> MockWallet
_mockWallet} = WalletInfo :: Wallet
-> PaymentPubKeyHash -> NonEmpty CardanoAddress -> WalletInfo
WalletInfo{Wallet
wiWallet :: Wallet
wiWallet :: Wallet
wiWallet, PaymentPubKeyHash
wiPaymentPubKeyHash :: PaymentPubKeyHash
wiPaymentPubKeyHash :: PaymentPubKeyHash
wiPaymentPubKeyHash, NonEmpty CardanoAddress
wiAddresses :: NonEmpty CardanoAddress
wiAddresses :: NonEmpty CardanoAddress
wiAddresses}
 where
    wiWallet :: Wallet
wiWallet = MockWallet -> Wallet
toMockWallet MockWallet
_mockWallet
    wiPaymentPubKeyHash :: PaymentPubKeyHash
wiPaymentPubKeyHash = Wallet -> PaymentPubKeyHash
mockWalletPaymentPubKeyHash Wallet
wiWallet
    wiAddresses :: NonEmpty CardanoAddress
wiAddresses = [CardanoAddress] -> NonEmpty CardanoAddress
forall a. [a] -> NonEmpty a
NonEmpty.fromList [Wallet -> CardanoAddress
mockWalletAddress Wallet
wiWallet]

data MultiWalletEffect r where
    CreateWallet :: Maybe Ada -> MultiWalletEffect WalletInfo
    MultiWallet :: Wallet -> Eff '[WalletEffect] a -> MultiWalletEffect a
    GetWalletInfo :: WalletId -> MultiWalletEffect (Maybe WalletInfo)
makeEffect ''MultiWalletEffect

type WalletEffects m = '[ MultiWalletEffect
                        , NodeClientEffect
                        , ChainIndexQueryEffect
                        , State Wallets
                        , Error PABError
                        , LogMsg Text
                        , Error WalletAPIError
                        , Error ClientError
                        , Error ServerError
                        , m]

newtype NodeClient = NodeClient ClientEnv

newtype ChainClient = ChainClient ClientEnv

newtype Port = Port Int
    deriving (Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show)
    deriving (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Integer -> Port
Port -> Port
Port -> Port -> Port
(Port -> Port -> Port)
-> (Port -> Port -> Port)
-> (Port -> Port -> Port)
-> (Port -> Port)
-> (Port -> Port)
-> (Port -> Port)
-> (Integer -> Port)
-> Num Port
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Port
$cfromInteger :: Integer -> Port
signum :: Port -> Port
$csignum :: Port -> Port
abs :: Port -> Port
$cabs :: Port -> Port
negate :: Port -> Port
$cnegate :: Port -> Port
* :: Port -> Port -> Port
$c* :: Port -> Port -> Port
- :: Port -> Port -> Port
$c- :: Port -> Port -> Port
+ :: Port -> Port -> Port
$c+ :: Port -> Port -> Port
Num, [Port] -> Encoding
[Port] -> Value
Port -> Encoding
Port -> Value
(Port -> Value)
-> (Port -> Encoding)
-> ([Port] -> Value)
-> ([Port] -> Encoding)
-> ToJSON Port
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Port] -> Encoding
$ctoEncodingList :: [Port] -> Encoding
toJSONList :: [Port] -> Value
$ctoJSONList :: [Port] -> Value
toEncoding :: Port -> Encoding
$ctoEncoding :: Port -> Encoding
toJSON :: Port -> Value
$ctoJSON :: Port -> Value
ToJSON, Value -> Parser [Port]
Value -> Parser Port
(Value -> Parser Port) -> (Value -> Parser [Port]) -> FromJSON Port
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Port]
$cparseJSONList :: Value -> Parser [Port]
parseJSON :: Value -> Parser Port
$cparseJSON :: Value -> Parser Port
FromJSON, [Port] -> Doc ann
Port -> Doc ann
(forall ann. Port -> Doc ann)
-> (forall ann. [Port] -> Doc ann) -> Pretty Port
forall ann. [Port] -> Doc ann
forall ann. Port -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [Port] -> Doc ann
$cprettyList :: forall ann. [Port] -> Doc ann
pretty :: Port -> Doc ann
$cpretty :: forall ann. Port -> Doc ann
Pretty) via Int

data WalletMsg = StartingWallet Port
               | ChainClientMsg Text
               | Balancing TxBalanceMsg
               | RequestHandling RequestHandlerLogMsg
    deriving stock (Int -> WalletMsg -> ShowS
[WalletMsg] -> ShowS
WalletMsg -> String
(Int -> WalletMsg -> ShowS)
-> (WalletMsg -> String)
-> ([WalletMsg] -> ShowS)
-> Show WalletMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WalletMsg] -> ShowS
$cshowList :: [WalletMsg] -> ShowS
show :: WalletMsg -> String
$cshow :: WalletMsg -> String
showsPrec :: Int -> WalletMsg -> ShowS
$cshowsPrec :: Int -> WalletMsg -> ShowS
Show, (forall x. WalletMsg -> Rep WalletMsg x)
-> (forall x. Rep WalletMsg x -> WalletMsg) -> Generic WalletMsg
forall x. Rep WalletMsg x -> WalletMsg
forall x. WalletMsg -> Rep WalletMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WalletMsg x -> WalletMsg
$cfrom :: forall x. WalletMsg -> Rep WalletMsg x
Generic)
    deriving anyclass ([WalletMsg] -> Encoding
[WalletMsg] -> Value
WalletMsg -> Encoding
WalletMsg -> Value
(WalletMsg -> Value)
-> (WalletMsg -> Encoding)
-> ([WalletMsg] -> Value)
-> ([WalletMsg] -> Encoding)
-> ToJSON WalletMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [WalletMsg] -> Encoding
$ctoEncodingList :: [WalletMsg] -> Encoding
toJSONList :: [WalletMsg] -> Value
$ctoJSONList :: [WalletMsg] -> Value
toEncoding :: WalletMsg -> Encoding
$ctoEncoding :: WalletMsg -> Encoding
toJSON :: WalletMsg -> Value
$ctoJSON :: WalletMsg -> Value
ToJSON, Value -> Parser [WalletMsg]
Value -> Parser WalletMsg
(Value -> Parser WalletMsg)
-> (Value -> Parser [WalletMsg]) -> FromJSON WalletMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [WalletMsg]
$cparseJSONList :: Value -> Parser [WalletMsg]
parseJSON :: Value -> Parser WalletMsg
$cparseJSON :: Value -> Parser WalletMsg
FromJSON)

instance Pretty WalletMsg where
    pretty :: WalletMsg -> Doc ann
pretty = \case
        StartingWallet Port
port -> Doc ann
"Starting wallet server on port" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Port -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Port
port
        ChainClientMsg Text
m    -> Doc ann
"Chain Client: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
m
        Balancing TxBalanceMsg
m         -> TxBalanceMsg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxBalanceMsg
m
        RequestHandling RequestHandlerLogMsg
m   -> RequestHandlerLogMsg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty RequestHandlerLogMsg
m

instance ToObject WalletMsg where
    toObject :: TracingVerbosity -> WalletMsg -> Object
toObject TracingVerbosity
_ = \case
        StartingWallet Port
port -> Text -> Tagged "port" Port -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Starting wallet server" (Port -> Tagged "port" Port
forall k (s :: k) b. b -> Tagged s b
Tagged @"port" Port
port)
        ChainClientMsg Text
m    -> Text -> Tagged "msg" Text -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Chain Client: " (Text -> Tagged "msg" Text
forall k (s :: k) b. b -> Tagged s b
Tagged @"msg" Text
m)
        Balancing TxBalanceMsg
m         -> Text -> Tagged "msg" TxBalanceMsg -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"Balancing" (TxBalanceMsg -> Tagged "msg" TxBalanceMsg
forall k (s :: k) b. b -> Tagged s b
Tagged @"msg" TxBalanceMsg
m)
        RequestHandling RequestHandlerLogMsg
m   -> Text -> Tagged "msg" RequestHandlerLogMsg -> Object
forall k. StructuredLog k => Text -> k -> Object
mkObjectStr Text
"RequestHandling" (RequestHandlerLogMsg -> Tagged "msg" RequestHandlerLogMsg
forall k (s :: k) b. b -> Tagged s b
Tagged @"msg" RequestHandlerLogMsg
m)