{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Node.Socket.Emulator.Mock where

import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (MVar, putMVar, takeMVar)
import Control.Lens (set, view)
import Control.Monad (forever, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Time.Clock.POSIX qualified as Time
import Data.Time.Units (Millisecond, toMicroseconds)
import Data.Time.Units.Extra ()
import Servant (NoContent (NoContent))

import Cardano.Node.Emulator.Internal.API (EmulatorLogs)
import Cardano.Node.Emulator.Internal.Node.TimeSlot (SlotConfig, currentSlot, nominalDiffTimeToPOSIXTime,
                                                     slotToBeginPOSIXTime)
import Cardano.Node.Socket.Emulator.Server qualified as Server
import Cardano.Node.Socket.Emulator.Types (AppState (..), emulatorLogs)

healthcheck :: Monad m => m NoContent
healthcheck :: m NoContent
healthcheck = NoContent -> m NoContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent

consumeEventHistory :: MonadIO m => MVar AppState -> m EmulatorLogs
consumeEventHistory :: MVar AppState -> m EmulatorLogs
consumeEventHistory MVar AppState
stateVar =
    IO EmulatorLogs -> m EmulatorLogs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EmulatorLogs -> m EmulatorLogs)
-> IO EmulatorLogs -> m EmulatorLogs
forall a b. (a -> b) -> a -> b
$ do
        AppState
oldState <- MVar AppState -> IO AppState
forall a. MVar a -> IO a
takeMVar MVar AppState
stateVar
        let events :: EmulatorLogs
events = Getting EmulatorLogs AppState EmulatorLogs
-> AppState -> EmulatorLogs
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EmulatorLogs AppState EmulatorLogs
Lens' AppState EmulatorLogs
emulatorLogs AppState
oldState
        let newState :: AppState
newState = ASetter AppState AppState EmulatorLogs EmulatorLogs
-> EmulatorLogs -> AppState -> AppState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter AppState AppState EmulatorLogs EmulatorLogs
Lens' AppState EmulatorLogs
emulatorLogs EmulatorLogs
forall a. Monoid a => a
mempty AppState
oldState
        MVar AppState -> AppState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar AppState
stateVar AppState
newState
        EmulatorLogs -> IO EmulatorLogs
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmulatorLogs
events

-- | Calls 'addBlock' at the start of every slot, causing pending transactions
--   to be validated and added to the chain.
slotCoordinator ::
    SlotConfig
    -> Server.ServerHandler
    -> IO a
slotCoordinator :: SlotConfig -> ServerHandler -> IO a
slotCoordinator SlotConfig
sc ServerHandler
serverHandler = do
    IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
        Slot
slot <- SlotConfig -> IO Slot
currentSlot SlotConfig
sc
        IO Slot -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Slot -> IO ()) -> IO Slot -> IO ()
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> ServerHandler -> IO Slot
forall (m :: * -> *).
MonadIO m =>
(Slot -> Slot) -> ServerHandler -> m Slot
Server.modifySlot (Slot -> Slot -> Slot
forall a b. a -> b -> a
const Slot
slot) ServerHandler
serverHandler
        POSIXTime
now <- IO POSIXTime
Time.getPOSIXTime
        let delay :: POSIXTime
delay = SlotConfig -> Slot -> POSIXTime
slotToBeginPOSIXTime SlotConfig
sc (Slot
slot Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
+ Slot
1) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime -> POSIXTime
nominalDiffTimeToPOSIXTime POSIXTime
now
        IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay
               (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
               (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Millisecond -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds (POSIXTime -> Millisecond
forall a b. (Integral a, Num b) => a -> b
fromIntegral POSIXTime
delay :: Millisecond)
        IO Block -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Block -> IO ()) -> IO Block -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerHandler -> IO Block
forall (m :: * -> *). MonadIO m => ServerHandler -> m Block
Server.processBlock ServerHandler
serverHandler