{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Data.Functor ((<&>))
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 (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 (ReadOnlyForker' m blk)))
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer ExtLedgerCfg blk
cfg Target (Point blk)
-> m (Either GetForkerError (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
    Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker' m blk))
getView Target (Point blk)
mpt m (Either GetForkerError (ReadOnlyForker' m blk))
-> (Either GetForkerError (ReadOnlyForker' m blk)
    -> ServerStAcquiring blk (Point blk) (Query blk) m ())
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Right ReadOnlyForker' m blk
forker -> 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
$ ReadOnlyForker' m blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ReadOnlyForker' m blk
forker
      Left GetForkerError
e -> 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 ::
    ReadOnlyForker' m blk ->
    ServerStAcquired blk (Point blk) (Query blk) m ()
  acquired :: ReadOnlyForker' m blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ReadOnlyForker' m blk
forker =
    ServerStAcquired
      { recvMsgQuery :: forall result.
Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
recvMsgQuery = ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
forall result.
ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery 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 = ReadOnlyForker' m blk -> m ()
forall (m :: * -> *) (l :: LedgerStateKind) blk.
ReadOnlyForker m l blk -> m ()
roforkerClose ReadOnlyForker' m blk
forker

  handleQuery ::
    ReadOnlyForker' m blk ->
    Query blk result ->
    m (ServerStQuerying blk (Point blk) (Query blk) m () result)
  handleQuery :: forall result.
ReadOnlyForker' m blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery 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 forker)