{-# 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)