{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Tools.ImmDBServer.Diffusion (run) where

import           Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer)
import           Control.ResourceRegistry
import           Control.Tracer
import qualified Data.ByteString.Lazy as BL
import           Data.Functor.Contravariant ((>$<))
import           Data.Void (Void)
import           Network.Socket (SockAddr (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Config.SupportsNode
import           Ouroboros.Consensus.Node.InitStorage
                     (NodeInitStorage (nodeCheckIntegrity, nodeImmutableDbChunkInfo))
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints)
import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDbArgs (..))
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import           Ouroboros.Consensus.Util
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.ErrorPolicy (nullErrorPolicies)
import           Ouroboros.Network.IOManager (withIOManager)
import           Ouroboros.Network.Mux
import qualified Ouroboros.Network.NodeToNode as N2N
import           Ouroboros.Network.PeerSelection.PeerSharing.Codec
                     (decodeRemoteAddress, encodeRemoteAddress)
import qualified Ouroboros.Network.Snocket as Snocket
import           Ouroboros.Network.Socket (configureSocket)
import           System.FS.API (SomeHasFS (..))
import           System.FS.API.Types (MountPoint (MountPoint))
import           System.FS.IO (ioHasFS)

-- | Glue code for using just the bits from the Diffusion Layer that we need in
-- this context.
serve ::
     SockAddr
  -> N2N.Versions N2N.NodeToNodeVersion N2N.NodeToNodeVersionData
       (OuroborosApplicationWithMinimalCtx 'ResponderMode SockAddr BL.ByteString IO Void ())
  -> IO Void
serve :: SockAddr
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO Void ())
-> IO Void
serve SockAddr
sockAddr Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr ByteString IO Void ())
application = (IOManager -> IO Void) -> IO Void
WithIOManager
withIOManager \IOManager
iocp -> do
    let sn :: SocketSnocket
sn     = IOManager -> SocketSnocket
Snocket.socketSnocket IOManager
iocp
        family :: AddressFamily SockAddr
family = SocketSnocket -> SockAddr -> AddressFamily SockAddr
forall (m :: * -> *) fd addr.
Snocket m fd addr -> addr -> AddressFamily addr
Snocket.addrFamily SocketSnocket
sn SockAddr
sockAddr
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO Void) -> IO Void
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (SocketSnocket -> AddressFamily SockAddr -> IO Socket
forall (m :: * -> *) fd addr.
Snocket m fd addr -> AddressFamily addr -> m fd
Snocket.open SocketSnocket
sn AddressFamily SockAddr
family) (SocketSnocket -> Socket -> IO ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.close SocketSnocket
sn) \Socket
socket -> do
      NetworkMutableState SockAddr
networkMutableState <- IO (NetworkMutableState SockAddr)
forall addr. IO (NetworkMutableState addr)
N2N.newNetworkMutableState
      Socket -> Maybe SockAddr -> IO ()
configureSocket Socket
socket (SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just SockAddr
sockAddr)
      SocketSnocket -> Socket -> SockAddr -> IO ()
forall (m :: * -> *) fd addr.
Snocket m fd addr -> fd -> addr -> m ()
Snocket.bind SocketSnocket
sn Socket
socket SockAddr
sockAddr
      SocketSnocket -> Socket -> IO ()
forall (m :: * -> *) fd addr. Snocket m fd addr -> fd -> m ()
Snocket.listen SocketSnocket
sn Socket
socket
      SocketSnocket
-> NetworkServerTracers SockAddr NodeToNodeVersion
-> NetworkMutableState SockAddr
-> AcceptedConnectionsLimit
-> Socket
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO Void ())
-> ErrorPolicies
-> IO Void
forall a b.
SocketSnocket
-> NetworkServerTracers SockAddr NodeToNodeVersion
-> NetworkMutableState SockAddr
-> AcceptedConnectionsLimit
-> Socket
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO a b)
-> ErrorPolicies
-> IO Void
N2N.withServer
        SocketSnocket
sn
        NetworkServerTracers SockAddr Any
forall addr vNumber. NetworkServerTracers addr vNumber
N2N.nullNetworkServerTracers {
          N2N.nstHandshakeTracer   = show >$< stdoutTracer
        , N2N.nstErrorPolicyTracer = show >$< stdoutTracer
        }
        NetworkMutableState SockAddr
networkMutableState
        AcceptedConnectionsLimit
acceptedConnectionsLimit
        Socket
socket
        Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosApplicationWithMinimalCtx
     'ResponderMode SockAddr ByteString IO Void ())
application
        ErrorPolicies
nullErrorPolicies
  where
    acceptedConnectionsLimit :: AcceptedConnectionsLimit
acceptedConnectionsLimit = N2N.AcceptedConnectionsLimit {
          acceptedConnectionsHardLimit :: Word32
N2N.acceptedConnectionsHardLimit = Word32
forall a. Bounded a => a
maxBound
        , acceptedConnectionsSoftLimit :: Word32
N2N.acceptedConnectionsSoftLimit = Word32
forall a. Bounded a => a
maxBound
        , acceptedConnectionsDelay :: DiffTime
N2N.acceptedConnectionsDelay     = DiffTime
0
        }

run ::
     forall blk.
     ( GetPrevHash blk
     , ShowProxy blk
     , SupportedNetworkProtocolVersion blk
     , SerialiseNodeToNodeConstraints blk
     , ImmutableDB.ImmutableDbSerialiseConstraints blk
     , NodeInitStorage blk
     , ConfigSupportsNode blk
     )
  => FilePath
  -> SockAddr
  -> TopLevelConfig blk
  -> IO Void
run :: forall blk.
(GetPrevHash blk, ShowProxy blk,
 SupportedNetworkProtocolVersion blk,
 SerialiseNodeToNodeConstraints blk,
 ImmutableDbSerialiseConstraints blk, NodeInitStorage blk,
 ConfigSupportsNode blk) =>
String -> SockAddr -> TopLevelConfig blk -> IO Void
run String
immDBDir SockAddr
sockAddr TopLevelConfig blk
cfg = (ResourceRegistry IO -> IO Void) -> IO Void
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry IO
registry ->
    IO (ImmutableDB IO blk)
-> (ImmutableDB IO blk -> IO Void) -> IO Void
forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
ImmutableDB.withDB
      (Complete ImmutableDbArgs IO blk
-> (forall st.
    WithTempRegistry st IO (ImmutableDB IO blk, st)
    -> IO (ImmutableDB IO blk))
-> IO (ImmutableDB IO blk)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st) -> ans)
-> ans
ImmutableDB.openDB (HKD Identity (ResourceRegistry IO)
-> Complete ImmutableDbArgs IO blk
forall {m :: * -> *} {f :: * -> *} {blk} {m :: * -> *}.
(PrimState m ~ RealWorld, HKD f (blk -> Bool) ~ (blk -> Bool),
 HKD f (CodecConfig blk) ~ CodecConfig blk,
 HKD f (SomeHasFS m) ~ SomeHasFS m, HKD f ChunkInfo ~ ChunkInfo,
 MonadIO m, Applicative m) =>
HKD f (ResourceRegistry m) -> ImmutableDbArgs f m blk
immDBArgs HKD Identity (ResourceRegistry IO)
ResourceRegistry IO
registry) WithTempRegistry st IO (ImmutableDB IO blk, st)
-> IO (ImmutableDB IO blk)
forall st.
WithTempRegistry st IO (ImmutableDB IO blk, st)
-> IO (ImmutableDB IO blk)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry)
      \ImmutableDB IO blk
immDB -> SockAddr
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO Void ())
-> IO Void
serve SockAddr
sockAddr (Versions
   NodeToNodeVersion
   NodeToNodeVersionData
   (OuroborosApplicationWithMinimalCtx
      'ResponderMode SockAddr ByteString IO Void ())
 -> IO Void)
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO Void ())
-> IO Void
forall a b. (a -> b) -> a -> b
$ CodecConfig blk
-> (NodeToNodeVersion -> SockAddr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s SockAddr)
-> ImmutableDB IO blk
-> NetworkMagic
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode SockAddr ByteString IO Void ())
forall (m :: * -> *) blk addr.
(IOLike m, HasHeader blk, ShowProxy blk,
 SerialiseNodeToNodeConstraints blk,
 SupportedNetworkProtocolVersion blk) =>
CodecConfig blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> ImmutableDB m blk
-> NetworkMagic
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode addr ByteString m Void ())
immDBServer
        CodecConfig blk
codecCfg
        NodeToNodeVersion -> SockAddr -> Encoding
encodeRemoteAddress
        NodeToNodeVersion -> Decoder s SockAddr
NodeToNodeVersion -> forall s. Decoder s SockAddr
forall s. NodeToNodeVersion -> Decoder s SockAddr
decodeRemoteAddress
        ImmutableDB IO blk
immDB
        NetworkMagic
networkMagic
  where
    immDBArgs :: HKD f (ResourceRegistry m) -> ImmutableDbArgs f m blk
immDBArgs HKD f (ResourceRegistry m)
registry = Incomplete ImmutableDbArgs m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete ImmutableDbArgs m blk
ImmutableDB.defaultArgs {
          immCheckIntegrity = nodeCheckIntegrity storageCfg
        , immChunkInfo      = nodeImmutableDbChunkInfo storageCfg
        , immCodecConfig    = codecCfg
        , immRegistry       = registry
        , immHasFS          = SomeHasFS $ ioHasFS $ MountPoint immDBDir
        }

    codecCfg :: CodecConfig blk
codecCfg     = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg
    storageCfg :: StorageConfig blk
storageCfg   = TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg
    networkMagic :: NetworkMagic
networkMagic = BlockConfig blk -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (BlockConfig blk -> NetworkMagic)
-> (TopLevelConfig blk -> BlockConfig blk)
-> TopLevelConfig blk
-> NetworkMagic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock (TopLevelConfig blk -> NetworkMagic)
-> TopLevelConfig blk -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk
cfg