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