{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..))
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
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, ConfigSupportsNode blk, HasAnnTip blk)
  => ExtLedgerCfg blk
  -> STM m (Point blk)
     -- ^ Get tip point
  -> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
     -- ^ Get a past ledger
  -> STM m (Point blk)
     -- ^ Get the immutable point
  -> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
 HasAnnTip blk) =>
ExtLedgerCfg blk
-> STM m (Point blk)
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> STM m (Point blk)
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer ExtLedgerCfg blk
cfg STM m (Point blk)
getTipPoint Point blk -> STM m (Maybe (ExtLedgerState blk))
getPastLedger STM m (Point blk)
getImmutablePoint =
    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)
tpt = do
        (Point blk
pt, Maybe (ExtLedgerState blk)
mPastLedger, Point blk
immutablePoint) <- STM m (Point blk, Maybe (ExtLedgerState blk), Point blk)
-> m (Point blk, Maybe (ExtLedgerState blk), Point blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk, Maybe (ExtLedgerState blk), Point blk)
 -> m (Point blk, Maybe (ExtLedgerState blk), Point blk))
-> STM m (Point blk, Maybe (ExtLedgerState blk), Point blk)
-> m (Point blk, Maybe (ExtLedgerState blk), Point blk)
forall a b. (a -> b) -> a -> b
$ do
          Point blk
pt <- case Target (Point blk)
tpt of
                  Target (Point blk)
VolatileTip         -> STM m (Point blk)
getTipPoint
                  SpecificPoint Point blk
point -> Point blk -> STM m (Point blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Point blk
point
                  Target (Point blk)
ImmutableTip        -> STM m (Point blk)
getImmutablePoint
          (Point blk
pt,,) (Maybe (ExtLedgerState blk)
 -> Point blk -> (Point blk, Maybe (ExtLedgerState blk), Point blk))
-> STM m (Maybe (ExtLedgerState blk))
-> STM
     m (Point blk -> (Point blk, Maybe (ExtLedgerState blk), Point blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point blk -> STM m (Maybe (ExtLedgerState blk))
getPastLedger Point blk
pt STM
  m (Point blk -> (Point blk, Maybe (ExtLedgerState blk), Point blk))
-> STM m (Point blk)
-> STM m (Point blk, Maybe (ExtLedgerState blk), Point blk)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m (Point blk)
getImmutablePoint

        ServerStAcquiring blk (Point blk) (Query blk) m ()
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 Maybe (ExtLedgerState blk)
mPastLedger of
          Just ExtLedgerState blk
pastLedger
            -> 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
$ ExtLedgerState blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ExtLedgerState blk
pastLedger
          Maybe (ExtLedgerState blk)
Nothing
            | Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
immutablePoint
            -> 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
            | Bool
otherwise
            -> 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 :: ExtLedgerState blk
             -> ServerStAcquired blk (Point blk) (Query blk) m ()
    acquired :: ExtLedgerState blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ExtLedgerState blk
st = ServerStAcquired {
          recvMsgQuery :: forall result.
Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
recvMsgQuery     = ExtLedgerState blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
forall result.
ExtLedgerState blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ExtLedgerState blk
st
        , recvMsgReAcquire :: Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
recvMsgReAcquire = Target (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire
        , recvMsgRelease :: m (ServerStIdle blk (Point blk) (Query blk) m ())
recvMsgRelease   = 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
        }

    handleQuery ::
         ExtLedgerState blk
      -> Query blk result
      -> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
    handleQuery :: forall result.
ExtLedgerState blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ExtLedgerState blk
st Query blk result
query = ServerStQuerying blk (Point blk) (Query blk) m () result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStQuerying blk (Point blk) (Query blk) m () result
 -> m (ServerStQuerying blk (Point blk) (Query blk) m () result))
-> ServerStQuerying blk (Point blk) (Query blk) m () result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
forall a b. (a -> b) -> a -> b
$
        result
-> ServerStAcquired blk (Point blk) (Query blk) m ()
-> ServerStQuerying blk (Point blk) (Query blk) m () result
forall result block point (query :: * -> *) (m :: * -> *) a.
result
-> ServerStAcquired block point query m a
-> ServerStQuerying block point query m a result
SendMsgResult
          (ExtLedgerCfg blk
-> Query blk result -> ExtLedgerState blk -> result
forall blk result.
(BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
 HasAnnTip blk) =>
ExtLedgerCfg blk
-> Query blk result -> ExtLedgerState blk -> result
answerQuery ExtLedgerCfg blk
cfg Query blk result
query ExtLedgerState blk
st)
          (ExtLedgerState blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ExtLedgerState blk
st)