{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
module Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server (localStateQueryServer) where

import           Ouroboros.Network.Protocol.LocalStateQuery.Server
import           Ouroboros.Network.Protocol.LocalStateQuery.Type
                     (AcquireFailure (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..))
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Util.IOLike

localStateQueryServer ::
     forall m blk. (IOLike m, QueryLedger 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 :: 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 (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 :: forall block point (query :: * -> *) (m :: * -> *) a.
(Maybe point -> m (ServerStAcquiring block point query m a))
-> m a -> ServerStIdle block point query m a
ServerStIdle {
          recvMsgAcquire :: Maybe (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
recvMsgAcquire = Maybe (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire
        , recvMsgDone :: m ()
recvMsgDone    = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }

    handleAcquire :: Maybe (Point blk)
                  -> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
    handleAcquire :: Maybe (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
handleAcquire Maybe (Point blk)
mpt = 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 (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 <- STM m (Point blk)
-> (Point blk -> STM m (Point blk))
-> Maybe (Point blk)
-> STM m (Point blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM m (Point blk)
getTipPoint Point blk -> STM m (Point blk)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Point blk)
mpt
          (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 (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 (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 block. 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 block. 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
ledgerState = ServerStAcquired :: forall block point (query :: * -> *) (m :: * -> *) a.
(forall result.
 query result -> m (ServerStQuerying block point query m a result))
-> (Maybe point -> m (ServerStAcquiring block point query m a))
-> m (ServerStIdle block point query m a)
-> ServerStAcquired block point query m a
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
ledgerState
        , recvMsgReAcquire :: Maybe (Point blk)
-> m (ServerStAcquiring blk (Point blk) (Query blk) m ())
recvMsgReAcquire = Maybe (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 (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 :: ExtLedgerState blk
-> Query blk result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
handleQuery ExtLedgerState blk
ledgerState Query blk result
query = ServerStQuerying blk (Point blk) (Query blk) m () result
-> m (ServerStQuerying blk (Point blk) (Query blk) m () result)
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.
(QueryLedger blk, ConfigSupportsNode blk, HasAnnTip blk) =>
ExtLedgerCfg blk
-> Query blk result -> ExtLedgerState blk -> result
answerQuery ExtLedgerCfg blk
cfg Query blk result
query ExtLedgerState blk
ledgerState)
          (ExtLedgerState blk
-> ServerStAcquired blk (Point blk) (Query blk) m ()
acquired ExtLedgerState blk
ledgerState)