{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeApplications   #-}

module Cardano.Node.Socket.Emulator
    ( main
    ) where

import Cardano.BM.Data.Trace (Trace)
import Cardano.Node.Emulator.Internal.Node (Params (..), SlotConfig (SlotConfig, scSlotLength, scSlotZeroTime))
import Cardano.Node.Socket.Emulator.API (API)
import Cardano.Node.Socket.Emulator.Mock (consumeEventHistory, healthcheck, slotCoordinator)
import Cardano.Node.Socket.Emulator.Params qualified as Params
import Cardano.Node.Socket.Emulator.Server qualified as Server
import Cardano.Node.Socket.Emulator.Types (AppState (..), CNSEServerLogMsg (..), NodeServerConfig (..),
                                           initialChainState)
import Control.Concurrent (MVar, forkIO, newMVar)
import Control.Monad (void)
import Control.Monad.Freer.Extras.Delay (delayThread, handleDelayEffect)
import Control.Monad.Freer.Extras.Log (logInfo)
import Control.Monad.IO.Class (liftIO)
import Data.Function ((&))
import Data.Map.Strict qualified as Map
import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.Units (Millisecond, Second)
import Ledger.CardanoWallet (knownAddresses)
import Ledger.Value.CardanoAPI qualified as CardanoAPI
import Network.Wai.Handler.Warp qualified as Warp
import Plutus.Monitoring.Util qualified as LM
import Servant (Application, hoistServer, serve, (:<|>) ((:<|>)))
import Servant.Client (BaseUrl (baseUrlPort))

app ::
    Trace IO CNSEServerLogMsg
 -> Params
 -> MVar AppState
 -> Application
app :: Trace IO CNSEServerLogMsg -> Params -> MVar AppState -> Application
app Trace IO CNSEServerLogMsg
trace Params
params MVar AppState
stateVar =
    Proxy API -> Server API -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy API
forall k (t :: k). Proxy t
Proxy @API) (Server API -> Application) -> Server API -> Application
forall a b. (a -> b) -> a -> b
$
    Proxy API
-> (forall x.
    ExceptT EmulatorError (RWST Params EmulatorLogs EmulatorState IO) x
    -> Handler x)
-> ServerT
     API
     (ExceptT EmulatorError (RWST Params EmulatorLogs EmulatorState IO))
-> Server API
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer
        (Proxy API
forall k (t :: k). Proxy t
Proxy @API)
        (IO x -> Handler x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> Handler x)
-> (EmulatorT IO x -> IO x) -> EmulatorT IO x -> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO EmulatorMsg
-> Params -> MVar AppState -> EmulatorT IO x -> IO x
forall a.
Trace IO EmulatorMsg
-> Params -> MVar AppState -> EmulatorT IO a -> IO a
Server.processChainEffects ((EmulatorMsg -> CNSEServerLogMsg)
-> Trace IO CNSEServerLogMsg -> Trace IO EmulatorMsg
forall a b (m :: * -> *). (a -> b) -> Trace m b -> Trace m a
LM.convertLog EmulatorMsg -> CNSEServerLogMsg
ProcessingEmulatorMsg Trace IO CNSEServerLogMsg
trace) Params
params MVar AppState
stateVar)
        (ExceptT
  EmulatorError (RWST Params EmulatorLogs EmulatorState IO) NoContent
forall (m :: * -> *). Monad m => m NoContent
healthcheck ExceptT
  EmulatorError (RWST Params EmulatorLogs EmulatorState IO) NoContent
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState IO)
     EmulatorLogs
-> ExceptT
     EmulatorError (RWST Params EmulatorLogs EmulatorState IO) NoContent
   :<|> ExceptT
          EmulatorError
          (RWST Params EmulatorLogs EmulatorState IO)
          EmulatorLogs
forall a b. a -> b -> a :<|> b
:<|> MVar AppState
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState IO)
     EmulatorLogs
forall (m :: * -> *). MonadIO m => MVar AppState -> m EmulatorLogs
consumeEventHistory MVar AppState
stateVar)

data Ctx = Ctx { Ctx -> ServerHandler
serverHandler :: Server.ServerHandler
               , Ctx -> MVar AppState
serverState   :: MVar AppState
               , Ctx -> Trace IO CNSEServerLogMsg
mockTrace     :: Trace IO CNSEServerLogMsg
               }

main :: Trace IO CNSEServerLogMsg -> NodeServerConfig -> IO () -> IO ()
main :: Trace IO CNSEServerLogMsg -> NodeServerConfig -> IO () -> IO ()
main Trace IO CNSEServerLogMsg
trace nodeServerConfig :: NodeServerConfig
nodeServerConfig@NodeServerConfig { BaseUrl
nscBaseUrl :: NodeServerConfig -> BaseUrl
nscBaseUrl :: BaseUrl
nscBaseUrl
                            , SlotConfig
nscSlotConfig :: NodeServerConfig -> SlotConfig
nscSlotConfig :: SlotConfig
nscSlotConfig
                            , Integer
nscKeptBlocks :: NodeServerConfig -> Integer
nscKeptBlocks :: Integer
nscKeptBlocks
                            , [WalletNumber]
nscInitialTxWallets :: NodeServerConfig -> [WalletNumber]
nscInitialTxWallets :: [WalletNumber]
nscInitialTxWallets
                            , FilePath
nscSocketPath :: NodeServerConfig -> FilePath
nscSocketPath :: FilePath
nscSocketPath } IO ()
whenStarted = Trace IO CNSEServerLogMsg
-> Eff '[LogMsg CNSEServerLogMsg, IO] ~> IO
forall (m :: * -> *) l.
MonadIO m =>
Trace m l -> Eff '[LogMsg l, m] ~> m
LM.runLogEffects Trace IO CNSEServerLogMsg
trace (Eff '[LogMsg CNSEServerLogMsg, IO] () -> IO ())
-> Eff '[LogMsg CNSEServerLogMsg, IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    -- make initial distribution of 1 billion Ada to all configured wallets
    let getAddress :: a -> CardanoAddress
getAddress a
n = [CardanoAddress]
knownAddresses [CardanoAddress] -> Int -> CardanoAddress
forall a. [a] -> Int -> a
!! (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        dist :: Map CardanoAddress Value
dist = [(CardanoAddress, Value)] -> Map CardanoAddress Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CardanoAddress, Value)] -> Map CardanoAddress Value)
-> [(CardanoAddress, Value)] -> Map CardanoAddress Value
forall a b. (a -> b) -> a -> b
$ [CardanoAddress] -> [Value] -> [(CardanoAddress, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip (WalletNumber -> CardanoAddress
forall a. Integral a => a -> CardanoAddress
getAddress (WalletNumber -> CardanoAddress)
-> [WalletNumber] -> [CardanoAddress]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WalletNumber]
nscInitialTxWallets) (Value -> [Value]
forall a. a -> [a]
repeat (Rational -> Value
CardanoAPI.adaValueOf Rational
1_000_000_000))
    SocketEmulatorState
initialState <- Map CardanoAddress Value
-> Eff '[LogMsg CNSEServerLogMsg, IO] SocketEmulatorState
forall (m :: * -> *).
MonadIO m =>
Map CardanoAddress Value -> m SocketEmulatorState
initialChainState Map CardanoAddress Value
dist
    let appState :: AppState
appState = SocketEmulatorState -> EmulatorLogs -> AppState
AppState SocketEmulatorState
initialState EmulatorLogs
forall a. Monoid a => a
mempty
    Params
params <- IO Params -> Eff '[LogMsg CNSEServerLogMsg, IO] Params
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Params -> Eff '[LogMsg CNSEServerLogMsg, IO] Params)
-> IO Params -> Eff '[LogMsg CNSEServerLogMsg, IO] Params
forall a b. (a -> b) -> a -> b
$ NodeServerConfig -> IO Params
Params.fromNodeServerConfig NodeServerConfig
nodeServerConfig
    ServerHandler
serverHandler <- IO ServerHandler
-> Eff '[LogMsg CNSEServerLogMsg, IO] ServerHandler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerHandler
 -> Eff '[LogMsg CNSEServerLogMsg, IO] ServerHandler)
-> IO ServerHandler
-> Eff '[LogMsg CNSEServerLogMsg, IO] ServerHandler
forall a b. (a -> b) -> a -> b
$ Trace IO EmulatorMsg
-> FilePath -> Integer -> AppState -> Params -> IO ServerHandler
forall (m :: * -> *).
MonadIO m =>
Trace IO EmulatorMsg
-> FilePath -> Integer -> AppState -> Params -> m ServerHandler
Server.runServerNode ((EmulatorMsg -> CNSEServerLogMsg)
-> Trace IO CNSEServerLogMsg -> Trace IO EmulatorMsg
forall a b (m :: * -> *). (a -> b) -> Trace m b -> Trace m a
LM.convertLog EmulatorMsg -> CNSEServerLogMsg
ProcessingEmulatorMsg Trace IO CNSEServerLogMsg
trace) FilePath
nscSocketPath Integer
nscKeptBlocks AppState
appState Params
params
    MVar AppState
serverState   <- IO (MVar AppState)
-> Eff '[LogMsg CNSEServerLogMsg, IO] (MVar AppState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar AppState)
 -> Eff '[LogMsg CNSEServerLogMsg, IO] (MVar AppState))
-> IO (MVar AppState)
-> Eff '[LogMsg CNSEServerLogMsg, IO] (MVar AppState)
forall a b. (a -> b) -> a -> b
$ AppState -> IO (MVar AppState)
forall a. a -> IO (MVar a)
newMVar AppState
appState
    Eff '[DelayEffect, LogMsg CNSEServerLogMsg, IO] ()
-> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall (effs :: [* -> *]) (m :: * -> *).
(LastMember m effs, MonadIO m) =>
Eff (DelayEffect : effs) ~> Eff effs
handleDelayEffect (Eff '[DelayEffect, LogMsg CNSEServerLogMsg, IO] ()
 -> Eff '[LogMsg CNSEServerLogMsg, IO] ())
-> Eff '[DelayEffect, LogMsg CNSEServerLogMsg, IO] ()
-> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Second -> Eff '[DelayEffect, LogMsg CNSEServerLogMsg, IO] ()
forall a (effs :: [* -> *]).
(TimeUnit a, Member DelayEffect effs) =>
a -> Eff effs ()
delayThread (Second
2 :: Second)

    let ctx :: Ctx
ctx = Ctx :: ServerHandler -> MVar AppState -> Trace IO CNSEServerLogMsg -> Ctx
Ctx { serverHandler :: ServerHandler
serverHandler = ServerHandler
serverHandler
                  , serverState :: MVar AppState
serverState   = MVar AppState
serverState
                  , mockTrace :: Trace IO CNSEServerLogMsg
mockTrace     = Trace IO CNSEServerLogMsg
trace
                  }

    Ctx -> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall (m :: * -> *) (effs :: [* -> *]).
(MonadIO m, LastMember m effs,
 FindElem (LogMsg CNSEServerLogMsg) effs) =>
Ctx -> Eff effs ()
runSlotCoordinator Ctx
ctx

    CNSEServerLogMsg -> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (CNSEServerLogMsg -> Eff '[LogMsg CNSEServerLogMsg, IO] ())
-> CNSEServerLogMsg -> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Int -> CNSEServerLogMsg
StartingCNSEServer (Int -> CNSEServerLogMsg) -> Int -> CNSEServerLogMsg
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Int
baseUrlPort BaseUrl
nscBaseUrl
    IO () -> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff '[LogMsg CNSEServerLogMsg, IO] ())
-> IO () -> Eff '[LogMsg CNSEServerLogMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Settings -> Application -> IO ()
Warp.runSettings Settings
warpSettings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Trace IO CNSEServerLogMsg -> Params -> MVar AppState -> Application
app Trace IO CNSEServerLogMsg
trace Params
params MVar AppState
serverState

        where
            warpSettings :: Settings
warpSettings = Settings
Warp.defaultSettings Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Int -> Settings -> Settings
Warp.setPort (BaseUrl -> Int
baseUrlPort BaseUrl
nscBaseUrl) Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
Warp.setBeforeMainLoop IO ()
whenStarted

            runSlotCoordinator :: Ctx -> Eff effs ()
runSlotCoordinator (Ctx ServerHandler
serverHandler MVar AppState
_ Trace IO CNSEServerLogMsg
_)  = do
                let SlotConfig{POSIXTime
scSlotZeroTime :: POSIXTime
scSlotZeroTime :: SlotConfig -> POSIXTime
scSlotZeroTime, Integer
scSlotLength :: Integer
scSlotLength :: SlotConfig -> Integer
scSlotLength} = SlotConfig
nscSlotConfig
                CNSEServerLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (CNSEServerLogMsg -> Eff effs ())
-> CNSEServerLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Millisecond -> CNSEServerLogMsg
StartingSlotCoordination (POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
scSlotZeroTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Fractional a => a -> a -> a
/ POSIXTime
1000)
                                                   (Integer -> Millisecond
forall a. Num a => Integer -> a
fromInteger Integer
scSlotLength :: Millisecond)
                Eff effs ThreadId -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs ThreadId -> Eff effs ())
-> Eff effs ThreadId -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> Eff effs ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Eff effs ThreadId)
-> IO ThreadId -> Eff effs ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ SlotConfig -> ServerHandler -> IO ()
forall a. SlotConfig -> ServerHandler -> IO a
slotCoordinator SlotConfig
nscSlotConfig ServerHandler
serverHandler