{-# 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 qualified Network.Mux as Mux
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 'Mux.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 <- IO (NetworkMutableState SockAddr)
forall addr. IO (NetworkMutableState addr)
N2N.newNetworkMutableState
    configureSocket socket (Just sockAddr)
    Snocket.bind sn socket sockAddr
    Snocket.listen sn socket
    N2N.withServer
      sn
      N2N.nullNetworkServerTracers
        { N2N.nstHandshakeTracer = show >$< stdoutTracer
        , N2N.nstErrorPolicyTracer = show >$< stdoutTracer
        }
      networkMutableState
      acceptedConnectionsLimit
      socket
      application
      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 {f :: * -> *} {blk} {m :: * -> *} {m :: * -> *}.
(HKD f (blk -> Bool) ~ (blk -> Bool),
 HKD f (SomeHasFS m) ~ SomeHasFS m,
 HKD f (CodecConfig blk) ~ CodecConfig blk,
 HKD f ChunkInfo ~ ChunkInfo, PrimState m ~ RealWorld, 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