{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server (localStateQueryServer) where

import Control.Monad (void)
import Control.ResourceRegistry
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Query
  ( BlockSupportsLedgerQuery
  , Query
  )
import qualified Ouroboros.Consensus.Ledger.Query as Query
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol
  )
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Protocol.LocalStateQuery.Server
import Ouroboros.Network.Protocol.LocalStateQuery.Type
  ( AcquireFailure (..)
  , Target (..)
  )

localStateQueryServer ::
  forall m blk.
  ( IOLike m
  , BlockSupportsLedgerQuery blk
  , Query.ConfigSupportsNode blk
  , LedgerSupportsProtocol blk
  ) =>
  ExtLedgerCfg blk ->
  ( Target (Point blk) ->
    m (Either GetForkerError (ResourceKey m, ReadOnlyForker' m blk))
  ) ->
  LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
 LedgerSupportsProtocol blk) =>
ExtLedgerCfg blk
-> (Target (Point blk)
    -> m (Either
            GetForkerError (ResourceKey m, ReadOnlyForker' m blk)))
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer ExtLedgerCfg blk
cfg Target (Point blk)
-> m (Either GetForkerError (ResourceKey m, ReadOnlyForker' m blk))
getView =
  m (ServerStIdle blk (Point blk) (Query blk) m ())
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
forall block point (query :: * -> *) (m :: * -> *) a.
m (ServerStIdle block point query m a)
-> LocalStateQueryServer block point query m a
LocalStateQueryServer (m (ServerStIdle blk (Point blk) (Query blk) m ())
 -> LocalStateQueryServer blk (Point blk) (Query blk) m ())
-> m (ServerStIdle blk (Point blk) (Query blk) m ())
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
forall a b. (a -> b) -> a -> b
$ ServerStIdle blk (Point blk) (Query blk) m ()
-> m (ServerStIdle blk (Point blk) (Query blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerStIdle blk (Point blk) (Query blk) m ()
idle
 where
  idle :: ServerStIdle blk (Point blk) (Query blk) m ()
  idle :: ServerStIdle blk (Point blk) (Query blk) m ()
idle =
    ServerStIdle
      { recvMsgAcquire :: Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
recvMsgAcquire = Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire
      , recvMsgDone :: m ()
recvMsgDone = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      }

  handleAcquire ::
    Target (Point blk) ->
    m (ServerStAcquiring blk (Point blk) (Query blk) m ())
  handleAcquire :: Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire Target (Point blk)
mpt = do
    eForker <- Target (Point blk)
-> m (Either GetForkerError (ResourceKey m, ReadOnlyForker' m blk))
getView Target (Point blk)
mpt
    case eForker of
      Right (ResourceKey m
rk, ReadOnlyForker' m blk
forker) -> ServerStAcquiring blk (Point blk) (Query blk) m ()
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStAcquiring blk (Point blk) (Query blk) m ()
 -> m (ServerStAcquiring blk (Point blk) (Query blk) m ()))
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall a b. (a -> b) -> a -> b
$ ServerStAcquired blk (Point blk) (Query blk) m ()
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
forall block point (query :: * -> *) (m :: * -> *) a.
ServerStAcquired block point query m a
-> ServerStAcquiring block point query m a
SendMsgAcquired (ServerStAcquired blk (Point blk) (Query blk) m ()
 -> ServerStAcquiring blk (Point blk) (Query blk) m ())
-> ServerStAcquired blk (Point blk) (Query blk) m ()
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
forall a b. (a -> b) -> a -> b
$ ResourceKey m
-> ReadOnlyForker' m blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ResourceKey m
rk ReadOnlyForker' m blk
forker
      Left GetForkerError
e -> do
        ServerStAcquiring blk (Point blk) (Query blk) m ()
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStAcquiring blk (Point blk) (Query blk) m ()
 -> m (ServerStAcquiring blk (Point blk) (Query blk) m ()))
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall a b. (a -> b) -> a -> b
$ case GetForkerError
e of
          PointTooOld{} ->
            AcquireFailure
-> ServerStIdle blk (Point blk) (Query blk) m ()
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
forall block point (query :: * -> *) (m :: * -> *) a.
AcquireFailure
-> ServerStIdle block point query m a
-> ServerStAcquiring block point query m a
SendMsgFailure AcquireFailure
AcquireFailurePointTooOld ServerStIdle blk (Point blk) (Query blk) m ()
idle
          GetForkerError
PointNotOnChain ->
            AcquireFailure
-> ServerStIdle blk (Point blk) (Query blk) m ()
-> ServerStAcquiring blk (Point blk) (Query blk) m ()
forall block point (query :: * -> *) (m :: * -> *) a.
AcquireFailure
-> ServerStIdle block point query m a
-> ServerStAcquiring block point query m a
SendMsgFailure AcquireFailure
AcquireFailurePointNotOnChain ServerStIdle blk (Point blk) (Query blk) m ()
idle

  acquired ::
    ResourceKey m ->
    ReadOnlyForker' m blk ->
    ServerStAcquired blk (Point blk) (Query blk) m ()
  acquired :: ResourceKey m
-> ReadOnlyForker' m blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ResourceKey m
rk ReadOnlyForker' m blk
forker =
    ServerStAcquired
      { recvMsgQuery :: forall result.
Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
recvMsgQuery = ResourceKey m
-> ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
forall result.
ResourceKey m
-> ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ResourceKey m
rk ReadOnlyForker' m blk
forker
      , recvMsgReAcquire :: Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
recvMsgReAcquire = \Target (Point blk)
mp -> do m ()
close; Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire Target (Point blk)
mp
      , recvMsgRelease :: m (ServerStIdle blk (Point blk) (Query blk) m ())
recvMsgRelease = do m ()
close; ServerStIdle blk (Point blk) (Query blk) m ()
-> m (ServerStIdle blk (Point blk) (Query blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerStIdle blk (Point blk) (Query blk) m ()
idle
      }
   where
    close :: m ()
close = m (Maybe (Context m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Context m)) -> m ()) -> m (Maybe (Context m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release ResourceKey m
rk

  handleQuery ::
    ResourceKey m ->
    ReadOnlyForker' m blk ->
    Query blk result ->
    m (ServerStQuerying blk (Point blk) (Query blk) m () result)
  handleQuery :: forall result.
ResourceKey m
-> ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ResourceKey m
rk ReadOnlyForker' m blk
forker Query blk result
query = do
    result <- ExtLedgerCfg blk
-> ReadOnlyForker' m blk -> Query blk result -> m result
forall blk (m :: * -> *) result.
(BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
 HasAnnTip blk, MonadSTM m) =>
ExtLedgerCfg blk
-> ReadOnlyForker' m blk -> Query blk result -> m result
Query.answerQuery ExtLedgerCfg blk
cfg ReadOnlyForker' m blk
forker Query blk result
query
    return $ SendMsgResult result (acquired rk forker)