content: --  This Source Code Form is subject to the terms of the Mozilla Public
  --  License, v. 2.0. If a copy of the MPL was not distributed with this
  --  file, You can obtain one at http://mozilla.org/MPL/2.0/.
  
  {-# LANGUAGE TypeOperators #-}
  {-# OPTIONS_HADDOCK prune #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  -- |
  -- Copyright: © 2020 KtorZ <matthias.benkort@gmail.com>
  -- License: MPL-2.0
  -- Stability: Experimental
  -- Portability: Portable
  module Cardano.Network.Protocol.NodeToClient
      (
      -- * Building
        Block
      , Eras
      , SubmitTransactionError
      , SerializedTransaction
      , Client
      , Clients(..)
      , mkClient
  
      -- * Connecting
      , connectClient
      , codecs
      , cChainSyncCodec
      , cTxSubmissionCodec
      , cStateQueryCodec
      , cTxMonitorCodec
      , nodeToClientV_Latest
  
      -- * Running
      , runPeer
      , runPipelinedPeer
      , chainSyncClientPeerPipelined
      , localStateQueryClientPeer
      , localTxSubmissionClientPeer
      , localTxMonitorClientPeer
  
      -- * Helpers / Re-exports
      , Error (..)
      , HandshakeProtocolError (..)
      , NodeToClientVersion
      , GenTx
      , GenTxId
  
      -- * Boilerplate
      , localChainSync
      , localTxSubmission
      , localStateQuery
      , localTxMonitor
      ) where
  
  import Prelude hiding
      ( read
      )
  
  import Cardano.Chain.Slotting
      ( EpochSlots (..)
      )
  import Cardano.Network.Protocol.NodeToClient.Trace
      ( TraceClient (..)
      )
  import Cardano.Slotting.Slot
      ( SlotNo
      )
  import Control.Monad.Class.MonadAsync
      ( MonadAsync
      )
  import Control.Monad.Class.MonadST
      ( MonadST
      )
  import Control.Monad.Class.MonadThrow
      ( MonadMask
      , MonadThrow (..)
      )
  import Control.Monad.IO.Class
      ( MonadIO (..)
      )
  import Control.Tracer
      ( Tracer (..)
      , contramap
      , nullTracer
      )
  import Data.ByteString.Lazy
      ( ByteString
      )
  import Data.Kind
      ( Type
      )
  import Data.Map.Strict
      ( (!)
      )
  import Data.Proxy
      ( Proxy (..)
      )
  import Data.Void
      ( Void
      )
  import Network.Mux
      ( Error (..)
      , Mode (..)
      )
  import Network.TypedProtocol.Codec
      ( Codec
      )
  import Network.TypedProtocol.Codec.CBOR
      ( DeserialiseFailure
      )
  import Ouroboros.Consensus.Byron.Ledger.Config
      ( CodecConfig (..)
      )
  import Ouroboros.Consensus.Cardano
      ( CardanoBlock
      )
  import Ouroboros.Consensus.Cardano.Block
      ( CardanoEras
      , CodecConfig (..)
      , HardForkApplyTxErr
      , TxId (..)
      )
  import Ouroboros.Consensus.Ledger.Query
      ( Query (..)
      )
  import Ouroboros.Consensus.Ledger.SupportsMempool
      ( ConvertRawTxId (..)
      , GenTx
      , GenTxId
      )
  import Ouroboros.Consensus.Network.NodeToClient
      ( ClientCodecs
      , Codecs' (..)
      , clientCodecs
      )
  import Ouroboros.Consensus.Node.NetworkProtocolVersion
      ( SupportedNetworkProtocolVersion (..)
      )
  import Ouroboros.Consensus.Shelley.Crypto
      ( StandardCrypto
      )
  import Ouroboros.Consensus.Shelley.Ledger.Config
      ( CodecConfig (..)
      )
  import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol
      ()
  import Ouroboros.Network.Block
      ( Point (..)
      , Tip (..)
      )
  import Ouroboros.Network.Channel
      ( Channel
      , hoistChannel
      )
  import Ouroboros.Network.Driver.Simple
      ( TraceSendRecv
      , runPeer
      , runPipelinedPeer
      )
  import Ouroboros.Network.Mux
      ( MiniProtocolCb (..)
      , OuroborosApplication (..)
      , RunMiniProtocol (..)
      )
  import Ouroboros.Network.NodeToClient
      ( LocalAddress
      , MinimalInitiatorContext
      , NetworkConnectTracers (..)
      , NodeToClientProtocols (..)
      , NodeToClientVersion (..)
      , NodeToClientVersionData (..)
      , ResponderContext
      , connectTo
      , localSnocket
      , nodeToClientProtocols
      , withIOManager
      )
  import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
      ( ChainSyncClientPipelined
      , chainSyncClientPeerPipelined
      )
  import Ouroboros.Network.Protocol.ChainSync.Type
      ( ChainSync
      )
  import Ouroboros.Network.Protocol.Handshake.Type
      ( HandshakeProtocolError (..)
      )
  import Ouroboros.Network.Protocol.Handshake.Version
      ( combineVersions
      , simpleSingletonVersions
      )
  import Ouroboros.Network.Protocol.LocalStateQuery.Client
      ( LocalStateQueryClient
      , localStateQueryClientPeer
      )
  import Ouroboros.Network.Protocol.LocalStateQuery.Type
      ( LocalStateQuery
      , State (..)
      )
  import Ouroboros.Network.Protocol.LocalTxMonitor.Client
      ( LocalTxMonitorClient
      , localTxMonitorClientPeer
      )
  import Ouroboros.Network.Protocol.LocalTxMonitor.Type
      ( LocalTxMonitor
      )
  import Ouroboros.Network.Protocol.LocalTxSubmission.Client
      ( LocalTxSubmissionClient
      , localTxSubmissionClientPeer
      )
  import Ouroboros.Network.Protocol.LocalTxSubmission.Type
      ( LocalTxSubmission
      )
  
  import qualified Network.TypedProtocol.Stateful.Codec as Stateful
  import qualified Ouroboros.Network.Driver.Stateful as Stateful
  
  -- | Concrete block type.
  type Block = CardanoBlock StandardCrypto
  
  -- | Concrete eras type.
  type Eras = CardanoEras StandardCrypto
  
  -- | A helper to help getting more uniform type signatures by making the submit
  -- failure a function of a 'block' parameter
  type family SubmitTransactionError block :: Type where
      SubmitTransactionError (CardanoBlock crypto) = HardForkApplyTxErr (CardanoEras crypto)
  
  -- | A slightly more transparent type alias for 'GenTx''
  type SerializedTransaction = GenTx
  
  -- | Type representing a network client running two mini-protocols to sync
  -- from the chain and, submit transactions.
  type Client m = OuroborosApplication
      'InitiatorMode
          -- Initiator ~ Client (as opposed to Responder / Server)
      (MinimalInitiatorContext LocalAddress)
          -- Initiator context
      (ResponderContext LocalAddress)
          -- Responder context
      ByteString
          -- Concrete representation for bytes string
      m
          -- Underlying monad we run in
      ()
          -- Clients return type
      Void
  
  instance ConvertRawTxId (GenTx (CardanoBlock StandardCrypto)) where
      toRawTxIdHash = \case
          GenTxIdByron x -> toRawTxIdHash x
          GenTxIdShelley x -> toRawTxIdHash x
          GenTxIdAllegra x -> toRawTxIdHash x
          GenTxIdMary x -> toRawTxIdHash x
          GenTxIdAlonzo x -> toRawTxIdHash x
          GenTxIdBabbage x -> toRawTxIdHash x
          GenTxIdConway x -> toRawTxIdHash x
  
  -- | A handy type to pass clients around
  data Clients m block = Clients
      { chainSyncClient
          :: ChainSyncClientPipelined block (Point block) (Tip block) m ()
      , txSubmissionClient
          :: LocalTxSubmissionClient (SerializedTransaction block) (SubmitTransactionError block) m ()
      , txMonitorClient
          :: NodeToClientVersion -> LocalTxMonitorClient (GenTxId block) (GenTx block) SlotNo m ()
      , stateQueryClient
          :: LocalStateQueryClient block (Point block) (Query block) m ()
      }
  
  -- | Connect a client to a network, see `mkClient` to construct a network
  -- client interface.
  connectClient
      :: MonadIO m
      => Tracer IO (TraceClient tx err)
      -> (NodeToClientVersion -> NodeToClientVersionData -> Client IO)
      -> NodeToClientVersionData
      -> FilePath
      -> m ()
  connectClient tr client vData addr = liftIO $ withIOManager $ \iocp -> do
      connectTo (localSnocket iocp) tracers versions addr >>= either throwIO return
    where
      versions = combineVersions
          [ simpleSingletonVersions v vData (client v)
          | v <- [ nodeToClientV_Min .. nodeToClientV_Latest ]
          ]
  
      tracers :: NetworkConnectTracers LocalAddress NodeToClientVersion
      tracers = NetworkConnectTracers
          { nctMuxTracer = nullTracer
          , nctHandshakeTracer = contramap TrHandshake tr
          }
  
  nodeToClientV_Latest :: NodeToClientVersion
  nodeToClientV_Latest = maxBound
  
  nodeToClientV_Min :: NodeToClientVersion
  nodeToClientV_Min = NodeToClientV_17
  
  -- | Construct a network client
  mkClient
      :: forall m.
          ( MonadAsync m
          , MonadIO m
          , MonadMask m
          , MonadST m
          )
      => (forall a. m a -> IO a)
          -- ^ A natural transformation to unlift a particular 'm' into 'IO'.
      -> Tracer m (TraceClient (SerializedTransaction Block) (SubmitTransactionError Block))
          -- ^ Base trace for underlying protocols
      -> EpochSlots
          -- ^ Static blockchain parameters
      -> Clients m Block
          -- ^ Clients with the driving logic
      -> (NodeToClientVersion -> NodeToClientVersionData -> Client IO)
  mkClient unlift tr epochSlots clients = \nodeToClientV nodeToClientVData ->
      nodeToClientProtocols
          NodeToClientProtocols
              { localChainSyncProtocol =
                  InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel ->
                      localChainSync unlift trChainSync
                          (codecChainSync nodeToClientV)
                          (chainSyncClient clients)
                          (hoistChannel liftIO channel)
  
              , localTxSubmissionProtocol =
                  InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel ->
                      localTxSubmission unlift trTxSubmission
                          (codecTxSubmission nodeToClientV)
                          (txSubmissionClient clients)
                          (hoistChannel liftIO channel)
  
              , localTxMonitorProtocol =
                  InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel ->
                      localTxMonitor unlift trTxMonitor
                          (codecTxMonitor nodeToClientV)
                          (txMonitorClient clients nodeToClientV)
                          (hoistChannel liftIO channel)
  
              , localStateQueryProtocol =
                  InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel ->
                      localStateQuery unlift trStateQuery
                          (codecStateQuery nodeToClientV)
                          (stateQueryClient clients)
                          (hoistChannel liftIO channel)
              }
          nodeToClientV
          nodeToClientVData
    where
      trChainSync    = nullTracer
      codecChainSync = cChainSyncCodec . codecs epochSlots
  
      trTxSubmission    = contramap TrTxSubmission tr
      codecTxSubmission = cTxSubmissionCodec . codecs epochSlots
  
      trTxMonitor    = nullTracer
      codecTxMonitor = cTxMonitorCodec . codecs epochSlots
  
      trStateQuery    = nullTracer
      codecStateQuery = cStateQueryCodec . codecs epochSlots
  
  -- | Boilerplate for lifting a 'ChainSyncClientPipelined'
  localChainSync
      :: forall m protocol.
          ( protocol ~ ChainSync Block (Point Block) (Tip Block)
          , MonadThrow m
          , MonadAsync m
          )
      => (forall a. m a -> IO a)
          -- ^ A natural transformation to unlift a particular 'm' into 'IO'.
      -> Tracer m (TraceSendRecv protocol)
          -- ^ Base tracer for the mini-protocols
      -> Codec protocol DeserialiseFailure m ByteString
          -- ^ Codec for deserializing / serializing binary data
      -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
          -- ^ The actual chain sync client
      -> Channel m ByteString
          -- ^ A 'Channel' is a abstract communication instrument which
          -- transports serialized messages between peers (e.g. a unix
          -- socket).
      -> IO ((), Maybe ByteString)
  localChainSync unliftIO tr codec client channel =
      unliftIO $ runPipelinedPeer tr codec channel (chainSyncClientPeerPipelined client)
  
  -- | Boilerplate for lifting a 'LocalTxSubmissionClient'
  localTxSubmission
      :: forall m protocol.
          ( protocol ~ LocalTxSubmission (SerializedTransaction Block) (SubmitTransactionError Block)
          , MonadThrow m
          )
      => (forall a. m a -> IO a)
          -- ^ A natural transformation to unlift a particular 'm' into 'IO'.
      -> Tracer m (TraceSendRecv protocol)
          -- ^ Base tracer for the mini-protocols
      -> Codec protocol DeserialiseFailure m ByteString
          -- ^ Codec for deserializing / serializing binary data
      -> LocalTxSubmissionClient (SerializedTransaction Block) (SubmitTransactionError Block) m ()
          -- ^ Actual local tx submission client
      -> Channel m ByteString
          -- ^ A 'Channel' is an abstract communication instrument which
          -- transports serialized messages between peers (e.g. a unix
          -- socket).
      -> IO ((), Maybe ByteString)
  localTxSubmission unliftIO tr codec client channel =
      unliftIO $ runPeer tr codec channel (localTxSubmissionClientPeer client)
  
  -- | Boilerplate for lifting a 'LocalTxMonitorClient'
  localTxMonitor
      :: forall m protocol a.
          ( protocol ~ LocalTxMonitor (GenTxId Block) (GenTx Block) SlotNo
          , MonadThrow m
          )
      => (forall x. m x -> IO x)
          -- ^ A natural transformation to unlift a particular 'm' into 'IO'.
      -> Tracer m (TraceSendRecv protocol)
          -- ^ Base tracer for the mini-protocols
      -> Codec protocol DeserialiseFailure m ByteString
          -- ^ Codec for deserializing / serializing binary data
      -> LocalTxMonitorClient (GenTxId Block) (GenTx Block) SlotNo m a
          -- ^ Actual local tx submission client
      -> Channel m ByteString
          -- ^ A 'Channel' is an abstract communication instrument which
          -- transports serialized messages between peers (e.g. a unix
          -- socket).
      -> IO (a, Maybe ByteString)
  localTxMonitor unliftIO tr codec client channel =
      unliftIO $ runPeer tr codec channel (localTxMonitorClientPeer client)
  
  -- | Boilerplate for lifting a 'LocalStateQueryClient'
  localStateQuery
      :: forall m.
          ( MonadAsync m
          , MonadMask m
          )
      => (forall x. m x -> IO x)
          -- ^ A natural transformation to unlift a particular 'm' into 'IO'.
      -> Tracer m (Stateful.TraceSendRecv (LocalStateQuery Block (Point Block) (Query Block)) State)
          -- ^ Base tracer for the mini-protocols
      -> Stateful.Codec (LocalStateQuery Block (Point Block) (Query Block)) DeserialiseFailure State m ByteString
          -- ^ Codec for deserializing / serializing binary data
      -> LocalStateQueryClient Block (Point Block) (Query Block) m ()
          -- ^ Actual local state query client.
      -> Channel m ByteString
          -- ^ A 'Channel' is an abstract communication instrument which
          -- transports serialized messages between peers (e.g. a unix
          -- socket).
      -> IO ((), Maybe ByteString)
  localStateQuery unliftIO tr codec client channel =
      unliftIO $ Stateful.runPeer tr codec channel StateIdle (localStateQueryClientPeer client)
  
  -- | Client codecs for Cardano
  codecs
      :: forall m. (MonadST m)
      => EpochSlots
      -> NodeToClientVersion
      -> ClientCodecs Block m
  codecs epochSlots nodeToClientV =
      clientCodecs cfg (supportedVersions ! nodeToClientV) nodeToClientV
    where
      supportedVersions = supportedNodeToClientVersions (Proxy @Block)
      cfg = CardanoCodecConfig
          (let byron   = ByronCodecConfig epochSlots in byron)
          (let shelley = ShelleyCodecConfig in shelley)
          (let allegra = ShelleyCodecConfig in allegra)
          (let mary    = ShelleyCodecConfig in mary)
          (let alonzo  = ShelleyCodecConfig in alonzo)
          (let babbage = ShelleyCodecConfig in babbage)
          (let conway  = ShelleyCodecConfig in conway)
  