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

module Cardano.Node.Server
    ( main
    ) where

import Cardano.BM.Data.Trace (Trace)
import Cardano.Node.API (API)
import Cardano.Node.Emulator.Params (Params (..))
import Cardano.Node.Emulator.TimeSlot (SlotConfig (SlotConfig, scSlotLength, scSlotZeroTime))
import Cardano.Node.Mock
import Cardano.Node.Params qualified as Params
import Cardano.Node.Types
import Cardano.Protocol.Socket.Mock.Client qualified as Client
import Cardano.Protocol.Socket.Mock.Server qualified as Server
import Control.Concurrent (MVar, forkIO, newMVar)
import Control.Concurrent.Availability (Availability, available)
import Control.Monad (void)
import Control.Monad.Freer.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.Value.CardanoAPI qualified as CardanoAPI
import Network.Wai.Handler.Warp qualified as Warp
import Plutus.PAB.Arbitrary ()
import Plutus.PAB.Monitoring.Monitoring qualified as LM
import Servant (Application, hoistServer, serve, (:<|>) ((:<|>)))
import Servant.Client (BaseUrl (baseUrlPort))
import Wallet.Emulator.Wallet (fromWalletNumber)

app ::
    Trace IO PABServerLogMsg
 -> Params
 -> Client.TxSendHandle
 -> MVar AppState
 -> Application
app :: Trace IO PABServerLogMsg
-> Params -> TxSendHandle -> MVar AppState -> Application
app Trace IO PABServerLogMsg
trace Params
params TxSendHandle
clientHandler 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. Eff (NodeServerEffects IO) x -> Handler x)
-> ServerT API (Eff (NodeServerEffects 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)
-> (Eff (NodeServerEffects IO) x -> IO x)
-> Eff (NodeServerEffects IO) x
-> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) x
-> IO x
forall a.
Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO a
processChainEffects Trace IO PABServerLogMsg
trace Params
params (TxSendHandle -> Maybe TxSendHandle
forall a. a -> Maybe a
Just TxSendHandle
clientHandler) MVar AppState
stateVar)
        (Eff (NodeServerEffects IO) NoContent
forall (m :: * -> *). Monad m => m NoContent
healthcheck Eff (NodeServerEffects IO) NoContent
-> Eff (NodeServerEffects IO) [LogMessage PABServerLogMsg]
-> Eff (NodeServerEffects IO) NoContent
   :<|> Eff (NodeServerEffects IO) [LogMessage PABServerLogMsg]
forall a b. a -> b -> a :<|> b
:<|> MVar AppState
-> Eff (NodeServerEffects IO) [LogMessage PABServerLogMsg]
forall (m :: * -> *).
MonadIO m =>
MVar AppState -> m [LogMessage PABServerLogMsg]
consumeEventHistory MVar AppState
stateVar)

data Ctx = Ctx { Ctx -> ServerHandler
serverHandler :: Server.ServerHandler
               , Ctx -> TxSendHandle
txSendHandle  :: Client.TxSendHandle
               , Ctx -> MVar AppState
serverState   :: MVar AppState
               , Ctx -> Trace IO PABServerLogMsg
mockTrace     :: Trace IO PABServerLogMsg
               }

main :: Trace IO PABServerLogMsg -> PABServerConfig -> Availability -> IO ()
main :: Trace IO PABServerLogMsg
-> PABServerConfig -> Availability -> IO ()
main Trace IO PABServerLogMsg
trace nodeServerConfig :: PABServerConfig
nodeServerConfig@PABServerConfig { BaseUrl
pscBaseUrl :: PABServerConfig -> BaseUrl
pscBaseUrl :: BaseUrl
pscBaseUrl
                            , SlotConfig
pscSlotConfig :: PABServerConfig -> SlotConfig
pscSlotConfig :: SlotConfig
pscSlotConfig
                            , Integer
pscKeptBlocks :: PABServerConfig -> Integer
pscKeptBlocks :: Integer
pscKeptBlocks
                            , [WalletNumber]
pscInitialTxWallets :: PABServerConfig -> [WalletNumber]
pscInitialTxWallets :: [WalletNumber]
pscInitialTxWallets
                            , FilePath
pscSocketPath :: PABServerConfig -> FilePath
pscSocketPath :: FilePath
pscSocketPath } Availability
availability = Trace IO PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ~> IO
forall (m :: * -> *) l.
MonadIO m =>
Trace m l -> Eff '[LogMsg l, m] ~> m
LM.runLogEffects Trace IO PABServerLogMsg
trace (Eff '[LogMsg PABServerLogMsg, IO] () -> IO ())
-> Eff '[LogMsg PABServerLogMsg, IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    -- make initial distribution of 1 billion Ada to all configured wallets
    let dist :: Map Wallet Value
dist = [(Wallet, Value)] -> Map Wallet Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Wallet, Value)] -> Map Wallet Value)
-> [(Wallet, Value)] -> Map Wallet Value
forall a b. (a -> b) -> a -> b
$ [Wallet] -> [Value] -> [(Wallet, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip (WalletNumber -> Wallet
fromWalletNumber (WalletNumber -> Wallet) -> [WalletNumber] -> [Wallet]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WalletNumber]
pscInitialTxWallets) (Value -> [Value]
forall a. a -> [a]
repeat (Rational -> Value
CardanoAPI.adaValueOf Rational
1_000_000_000))
    MockNodeServerChainState
initialState <- Map Wallet Value
-> Eff '[LogMsg PABServerLogMsg, IO] MockNodeServerChainState
forall (m :: * -> *).
MonadIO m =>
Map Wallet Value -> m MockNodeServerChainState
initialChainState Map Wallet Value
dist
    let appState :: AppState
appState = AppState :: MockNodeServerChainState
-> [LogMessage PABServerLogMsg] -> AppState
AppState
            { _chainState :: MockNodeServerChainState
_chainState = MockNodeServerChainState
initialState
            , _eventHistory :: [LogMessage PABServerLogMsg]
_eventHistory = [LogMessage PABServerLogMsg]
forall a. Monoid a => a
mempty
            }
    Params
params <- IO Params -> Eff '[LogMsg PABServerLogMsg, IO] Params
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Params -> Eff '[LogMsg PABServerLogMsg, IO] Params)
-> IO Params -> Eff '[LogMsg PABServerLogMsg, IO] Params
forall a b. (a -> b) -> a -> b
$ PABServerConfig -> IO Params
Params.fromPABServerConfig PABServerConfig
nodeServerConfig
    ServerHandler
serverHandler <- IO ServerHandler -> Eff '[LogMsg PABServerLogMsg, IO] ServerHandler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerHandler
 -> Eff '[LogMsg PABServerLogMsg, IO] ServerHandler)
-> IO ServerHandler
-> Eff '[LogMsg PABServerLogMsg, IO] ServerHandler
forall a b. (a -> b) -> a -> b
$ Trace IO PABServerLogMsg
-> FilePath
-> Integer
-> MockNodeServerChainState
-> Params
-> IO ServerHandler
forall (m :: * -> *).
MonadIO m =>
Trace IO PABServerLogMsg
-> FilePath
-> Integer
-> MockNodeServerChainState
-> Params
-> m ServerHandler
Server.runServerNode Trace IO PABServerLogMsg
trace FilePath
pscSocketPath Integer
pscKeptBlocks (AppState -> MockNodeServerChainState
_chainState AppState
appState) Params
params
    MVar AppState
serverState   <- IO (MVar AppState)
-> Eff '[LogMsg PABServerLogMsg, IO] (MVar AppState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar AppState)
 -> Eff '[LogMsg PABServerLogMsg, IO] (MVar AppState))
-> IO (MVar AppState)
-> Eff '[LogMsg PABServerLogMsg, 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 PABServerLogMsg, IO] ()
-> Eff '[LogMsg PABServerLogMsg, IO] ()
forall (effs :: [* -> *]) (m :: * -> *).
(LastMember m effs, MonadIO m) =>
Eff (DelayEffect : effs) ~> Eff effs
handleDelayEffect (Eff '[DelayEffect, LogMsg PABServerLogMsg, IO] ()
 -> Eff '[LogMsg PABServerLogMsg, IO] ())
-> Eff '[DelayEffect, LogMsg PABServerLogMsg, IO] ()
-> Eff '[LogMsg PABServerLogMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Second -> Eff '[DelayEffect, LogMsg PABServerLogMsg, IO] ()
forall a (effs :: [* -> *]).
(TimeUnit a, Member DelayEffect effs) =>
a -> Eff effs ()
delayThread (Second
2 :: Second)
    TxSendHandle
clientHandler <- IO TxSendHandle -> Eff '[LogMsg PABServerLogMsg, IO] TxSendHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TxSendHandle -> Eff '[LogMsg PABServerLogMsg, IO] TxSendHandle)
-> IO TxSendHandle
-> Eff '[LogMsg PABServerLogMsg, IO] TxSendHandle
forall a b. (a -> b) -> a -> b
$ FilePath -> IO TxSendHandle
Client.runTxSender FilePath
pscSocketPath

    let ctx :: Ctx
ctx = Ctx :: ServerHandler
-> TxSendHandle -> MVar AppState -> Trace IO PABServerLogMsg -> Ctx
Ctx { serverHandler :: ServerHandler
serverHandler = ServerHandler
serverHandler
                  , txSendHandle :: TxSendHandle
txSendHandle  = TxSendHandle
clientHandler
                  , serverState :: MVar AppState
serverState   = MVar AppState
serverState
                  , mockTrace :: Trace IO PABServerLogMsg
mockTrace     = Trace IO PABServerLogMsg
trace
                  }

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

    PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ())
-> PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ()
forall a b. (a -> b) -> a -> b
$ Int -> PABServerLogMsg
StartingPABServer (Int -> PABServerLogMsg) -> Int -> PABServerLogMsg
forall a b. (a -> b) -> a -> b
$ BaseUrl -> Int
baseUrlPort BaseUrl
pscBaseUrl
    IO () -> Eff '[LogMsg PABServerLogMsg, IO] ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff '[LogMsg PABServerLogMsg, IO] ())
-> IO () -> Eff '[LogMsg PABServerLogMsg, 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 PABServerLogMsg
-> Params -> TxSendHandle -> MVar AppState -> Application
app Trace IO PABServerLogMsg
trace Params
params TxSendHandle
clientHandler 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
pscBaseUrl) Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
Warp.setBeforeMainLoop (Availability -> IO ()
forall (m :: * -> *). MonadIO m => Availability -> m ()
available Availability
availability)

            runSlotCoordinator :: Ctx -> Eff effs ()
runSlotCoordinator (Ctx ServerHandler
serverHandler TxSendHandle
_ MVar AppState
_ Trace IO PABServerLogMsg
_)  = do
                let SlotConfig{POSIXTime
scSlotZeroTime :: POSIXTime
scSlotZeroTime :: SlotConfig -> POSIXTime
scSlotZeroTime, Integer
scSlotLength :: Integer
scSlotLength :: SlotConfig -> Integer
scSlotLength} = SlotConfig
pscSlotConfig
                PABServerLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (PABServerLogMsg -> Eff effs ()) -> PABServerLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Millisecond -> PABServerLogMsg
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
pscSlotConfig ServerHandler
serverHandler